Создать конвертировать Excel (xls) в формат vCard (vcf)

mmouse_vcf_icon
Чтобы перенести контакты с одной платформы на другую очень удобно использовать файлы стандарта vCard. Файлы vCard (с расширением .VCF) понимают большинство почтовых программ, телефоны Apple и Android. С помощью этого формата можно легко перенести контакты с ios на android, импортировать адресную книгу Outlook и многое другое.

К сожалению программы для работы с файлами vCard в основном платные и не отличаются богатым функционалом. А меж тем, файл VCF представляет собой обычный текстовой файл в кодировке UTF-8. Для разовой правки подойдёт любой текстовой редактор. Но когда контактов несколько сотен, или они уже имеются в Excel, то можно воспользоваться нижеприведённым макросом.

Это простая программа поможет создать vCard VCF файл из Excel файла.

Для начала нужно подготовить сам документ.
mmouse_excel_to_vcf
Разместите данные, как указано на этом образце. Важно — имя листа должно быть Sheet1, ибо оно используется в программе.

В случае использования MS Office 2012 нужно будет сохранить файл как XLSM (файл Excel c макросами).
После этого открываем файл и жмём ALT+F11
mmouse_excel_to_vcf01
В открывшемся окне выберите ваш лист с данными и вставьте в окно для текста макроса такой текст

'External Properties & Functions Declaration
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal Operation As String, ByVal Filename As String, Optional ByVal Parameters As String, Optional ByVal Directory As String, Optional ByVal WindowStyle As Long = vbMinimizedFocus) As Long
Private Sub Create_VCF()
    'Open a File in Specific Path in Output or Append mode
    Dim FileNum As Integer
    Dim iRow As Double
    iRow = 2
    FileNum = FreeFile
    OutFilePath = ThisWorkbook.Path & "\OutputVCF.VCF"
    Open OutFilePath For Output As FileNum
 
    'Loop through Excel Sheet each row and write it to VCF File
    While VBA.Trim(Sheets("Sheet1").Cells(iRow, 1)) <> ""
        FName = VBA.Trim(Sheets("Sheet1").Cells(iRow, 1))
        LName = VBA.Trim(Sheets("Sheet1").Cells(iRow, 2))
        PhNum = VBA.Trim(Sheets("Sheet1").Cells(iRow, 3))
 
        Print #FileNum, "BEGIN:VCARD"
        Print #FileNum, "VERSION:3.0"
        Print #FileNum, "N:" & FName & ";" & LName & ";;;"
        Print #FileNum, "FN:" & FName & " " & LName
        Print #FileNum, "TEL;TYPE=CELL;TYPE=VOICE:" & PhNum
        Print #FileNum, "END:VCARD"
        iRow = iRow + 1
    Wend
 
    'Close The File
    Close #FileNum
    MsgBox "Contacts Converted to Saved To: " & OutFilePath & " - OK"
    
End Sub

Жмём F5 или кнопку «выполнить» на панели задач. Результирующий файл VCF будет создан рядом с исходным файлом Excel.

Как можно увидеть в этой программе, файл VCF весьма прост по своему устройству. Вы можете самостоятельно добавить в него нужные поля. Например я добавил поле «компания» по образцу VCF файла из моего iPhone.

28 комментариев to“Создать конвертировать Excel (xls) в формат vCard (vcf)”

  1. Максим
    20.05.2016 at 22:07 #

    Большое спасибо!)
    То, что нужно?

  2. Chumaziy
    23.06.2016 at 05:52 #

    С добавлением строки Email

    ‘External Properties & Functions Declaration
    Private Declare Function ShellExecute Lib «shell32.dll» Alias «ShellExecuteA» (ByVal hWnd As Long, ByVal Operation As String, ByVal Filename As String, Optional ByVal Parameters As String, Optional ByVal Directory As String, Optional ByVal WindowStyle As Long = vbMinimizedFocus) As Long
    Private Sub Create_VCF()
    ‘Open a File in Specific Path in Output or Append mode
    Dim FileNum As Integer
    Dim iRow As Double
    iRow = 2
    FileNum = FreeFile
    OutFilePath = ThisWorkbook.Path & «\OutputVCF.VCF»
    Open OutFilePath For Output As FileNum

    ‘Loop through Excel Sheet each row and write it to VCF File
    While VBA.Trim(Sheets(«Sheet1»).Cells(iRow, 1)) «»
    FName = VBA.Trim(Sheets(«Sheet1»).Cells(iRow, 1))
    LName = VBA.Trim(Sheets(«Sheet1»).Cells(iRow, 2))
    PhNum = VBA.Trim(Sheets(«Sheet1»).Cells(iRow, 3))
    Email = VBA.Trim(Sheets(«Sheet1»).Cells(iRow, 4))

    Print #FileNum, «BEGIN:VCARD»
    Print #FileNum, «VERSION:3.0»
    Print #FileNum, «N:» & FName & «;» & LName & «;;;»
    Print #FileNum, «FN:» & FName & » » & LName
    Print #FileNum, «TEL;TYPE=CELL;TYPE=VOICE:» & PhNum
    Print #FileNum, «EMAIL;PREF;INTERNET:» & Email
    Print #FileNum, «END:VCARD»
    iRow = iRow + 1
    Wend

    ‘Close The File
    Close #FileNum
    MsgBox «Contacts Converted to Saved To: » & OutFilePath & » — OK»

    End Sub

  3. Аноним
    24.06.2016 at 13:48 #

    Спасибо Автору! Почти месяц не мог найти нормальный конвертер. А тут за полчаса все поля нужные дописал и готово. Даже группы перенести удалось.

  4. Маха
    30.06.2016 at 05:25 #

    Спасибо огромное! Вы гений!

  5. Аноним
    19.07.2016 at 03:40 #

    Почему-то кириллица в телефоне читается вопросами

  6. Аноним
    26.07.2016 at 19:10 #

    аналогичная проблема с вопросами

  7. Денис
    22.08.2016 at 00:58 #

    Большое спасибо! Очень помогло.
    Если телефон принимает 2 столбца — имя с фамилией и номер телефона (как у меня), тогда вставляем вот такой текст:

    ‘External Properties & Functions Declaration
    Private Declare Function ShellExecute Lib «shell32.dll» Alias «ShellExecuteA» (ByVal hWnd As Long, ByVal Operation As String, ByVal Filename As String, Optional ByVal Parameters As String, Optional ByVal Directory As String, Optional ByVal WindowStyle As Long = vbMinimizedFocus) As Long
    Private Sub Create_VCF()
    ‘Open a File in Specific Path in Output or Append mode
    Dim FileNum As Integer
    Dim iRow As Double
    iRow = 2
    FileNum = FreeFile
    OutFilePath = ThisWorkbook.Path & «\OutputVCF.VCF»
    Open OutFilePath For Output As FileNum

    ‘Loop through Excel Sheet each row and write it to VCF File
    While VBA.Trim(Sheets(«Sheet1»).Cells(iRow, 1)) «»
    FName = VBA.Trim(Sheets(«Sheet1»).Cells(iRow, 1))
    PhNum = VBA.Trim(Sheets(«Sheet1»).Cells(iRow, 2))

    Print #FileNum, «BEGIN:VCARD»
    Print #FileNum, «VERSION:3.0»
    Print #FileNum, «FN:» & FName & » » & LName
    Print #FileNum, «TEL;TYPE=CELL;TYPE=VOICE:» & PhNum
    Print #FileNum, «END:VCARD»
    iRow = iRow + 1
    Wend

    ‘Close The File
    Close #FileNum
    MsgBox «Contacts Converted to Saved To: » & OutFilePath & » — OK»

    End Sub

  8. Аноним
    25.08.2016 at 07:51 #

    Автору низкий поклон

  9. Аноним
    02.09.2016 at 10:55 #

    кириллица в телефоне читается вопросами. Есть решение у кого?

  10. Аноним
    07.09.2016 at 14:15 #

    тем, у кого ромбы с вопросами видятся: нужно пересохранить (например, akelpad’ом) получившийся vcf в формат UTF-8. в akelpad открыть файл как ANSI, сохранить как UTF-8 со снятой галочкой BOM.

  11. Аноним
    07.09.2016 at 14:22 #

    ещё про ромбы — такая беда на всех андроидах, ибо UTF-8 без BOM это нормальный формат для андроида, другие он принимать если и будет, то только спецпрограммами сторонних разработчиков.

  12. Андрей
    25.09.2016 at 08:18 #

    А как модифицировать для 64х разрядной версии, кто-нибудь подскажет? У меня не хочет работать ну никак.

  13. Анатолий
    08.10.2016 at 20:19 #

    Здравствуйте! Подскажите пожалуйста, не могу понять в чём причина, после сохранения всего один контакт в файле и всё, остальных почти 200 нет. Как быть, в чём причина, где что не так? Спасибо заранее.

  14. Виктор
    10.10.2016 at 02:04 #

    А у меня почему-то все время конвертируется только 70 номеров из списка в 2100 шт

  15. Камиль
    31.10.2016 at 21:37 #

    Работает нормально!

  16. рома
    06.11.2016 at 19:54 #

    Не получается тоже скачивает 1 контакт из 240 в Csv

  17. Dmitriy
    22.11.2016 at 00:07 #

    Спасибо!! Красавчег!!!! дай рунет тебе 100 млн. подписчиков!!!

  18. Аноним
    22.12.2016 at 17:23 #

    Здравствуйте! Скажите пожалуйста, а как сохранить на Виндовс 7, у меня не получается!

  19. Аноним
    22.12.2016 at 17:31 #

    Скажите пожалуйста, а как сохранить на Виндовс 7, у меня не получается!

  20. Аноним
    27.12.2016 at 20:35 #

    Добрый день, а если мне надо загрузить «Имя», «номер телефона» и «почта» , какой алгоритм надо вставить ?

  21. 29.12.2016 at 12:36 #

    Здравствуйте,
    Точно не знаю, но скорее всего вам нужно добавить ещё один столбец — почта в Excel файл. Потом в тексте макроса подправить тут
    FName = VBA.Trim(Sheets(«Sheet1»).Cells(iRow, 1))
    LName = VBA.Trim(Sheets(«Sheet1»).Cells(iRow, 2))
    PhNum = VBA.Trim(Sheets(«Sheet1»).Cells(iRow, 3))

    после этих строчек. Что-то на подобии
    Email = VBA.Trim(Sheets(«Sheet1»).Cells(iRow, 4))

    и в выходном файле, где-то между

    Print #FileNum, «N:» & FName & «;» & LName & «;;;»
    Print #FileNum, «FN:» & FName & » » & LName
    Print #FileNum, «TEL;TYPE=CELL;TYPE=VOICE:» & PhNum
    Print #FileNum, «END:VCARD»

    поставить вывод почты. Примерно так:
    Print #FileNum, «MAIL:» & Email

    Посмотрите тестовый VCF файл на вашем устройстве, в каком месте там прописан email, туда и вставляйте. Он должен быть точно после имени-фамилии, по идее рядом с номером телефона.

  22. Надахто
    01.02.2017 at 19:57 #

    Низкий поклон! Вы мне очень помогли!

  23. Саша
    21.02.2017 at 08:35 #

    У меня все заработало, внимательно разбирайтесь, а когда будете сохранять в UTF-8 без BOM то перепроверяйте правильно ли сохранило, пробуйте сначало внизу акепада сохранить в UTF-8 а потом слева вверху пересохраните через замену файла уже без бом, у меня раз 50 не получилось, а потом получилось как хотел, 3000 контактов все-таки телефон прохавал)))

  24. Владимир
    09.03.2017 at 10:51 #

    Мда, и здесь облом. Простых решений не бывает. На 64-разрядной ОС Windows этот макрос не работает. И автор не хочет нам помочь.

  25. Владимир
    09.03.2017 at 16:38 #

    Предыдущее мое сообщение о том, что макрос якобы не работает на 64-битной ОС Виндовз, ошибочно! Сообщение об ошибке появляется в случае использования не оригинального кода автоа, а того модифицированного, который расположен чуть ниже оригинала. Там вместо символа кавычки латинские применяются кавычки кирилличные.

  26. 10.03.2017 at 22:53 #

    этот макрос писал в Windows 8.1 64 bit + MSO 2013 32 bit. 64 битной версии офиса у меня нет, проверить не могу.

  27. Даниил
    11.03.2017 at 08:15 #

    Как сделать так, чтобы макрос не исчезал после выполнения работы, а оставался в файле?

  28. Даниил
    11.03.2017 at 08:19 #

    Можно вместо Sheets1 везде поставить Лист1? Ничего не будет, если в файле 3 листа? или должен быть только 1, а остальные удалить надо?

Добавить комментарий

Ваш e-mail не будет опубликован.

Proudly powered by WordPress   Premium Style Theme by www.gopiplus.com