vCard contact export from Excel contact list

Recently I needed a way to easily convert a list with contact information into a vCard file, respecting the vCard syntax, in order to import this vCard contact information into a phone.

After some quick Google lookup I ended with this nice Excel created and shared by Savas Geivanidis.

After entering all the contact information into the sheet as instructed, the export macro started executing it’s work and I ended with a vCard file as I wanted. But the process took very long (more than 4 minutes), even if my contact list only contained 100 contacts.

Since Savas was so kind to keep his VBS macro unprotected, I analyzed it and optimized it. The main performance issues I detected was the multiple loops and the cell deletions used in the code. A loop was set up to run over the contact data, and copy all data it into a new sheet. Next a loop was used to run through the data and delete all cell containing the value ‘no data’. Next the new sheet was saved into a text .vcf file.

After rewriting the VBS macro I ended up with one loop, running through the data and saving the information immediately into a text file. The same list of 100 contacts now takes less than 1sec to export instead of more than 4 minutes. Some tests with 1000 contacts were positive as it took only 4sec or less to export. I ended up cleaning up the full sheet and creating a template of it to allow easy reuse. Feel free to use this version 1.0 of vCard Exporter for any purpose.

The optimized source code is shown below for illustration:

Sub Create_vCard() 
  
'

' This Macro creates a vCard from an existing phonebook Excel list

'__________________________________________________________________

' Based on DesktopContacts v0.8 by Savas Geivanidis (savas@mycosmos.gr) egnatia.ee.auth.gr/~aki/dc/DesktopContacts0.8.xls

' Major performance improvements by myT in vCardExporter v1.0

'___________________________________________________________________

    
    Application.ScreenUpdating = False

    ' turns off screen updating

    Application.DisplayStatusBar = True

    ' makes sure that the statusbar is visible

    
    'detect number of data contacts provided

    'mainsheet = ActiveSheet.Name

    mainsheet = "PhoneBook"

    Range("A30000").Select

    Selection.End(xlUp).Select

    nod = ActiveCell.Row

    Range("B30000").Select

    Selection.End(xlUp).Select

    nod1 = ActiveCell.Row

    If nod1 > nod Then

        nod = nod1

    End If

    
    'Check if data is provided

    If nod <= 2 Then

        popup = MsgBox("No contact data could be found. Fill in the contact data in the 'PhoneBook' sheet and provide at least a first or last name for each contact." & vbLf & "See the 'Information' sheet and http://myTselection.blogpsot.com for more information", vbExclamation + vbOKOnly + vbMsgBoxSetForeground, "vCard Exporter: No data found")

        Application.ScreenUpdating = True

        Exit Sub

    End If

    
    'request target filename

    vcardname = Application.GetSaveAsFilename("", "vCard Files (*.vcf), *.vcf", , "Please select the name of the vCard to export")

    If vcardname = False Then

        Application.ScreenUpdating = True

        Exit Sub

    End If

    start_time = Now()

    Application.StatusBar = "Preparing VCARD data"

    
    
    Set vcardFileSystemObject = CreateObject("Scripting.FileSystemObject")

    Set vcardFile = vcardFileSystemObject.CreateTextFile(vcardname, True)

    
    
    'copy formula for VCARD syntax to all rows with contact data

    Range(Cells(1, 61), Cells(1, 101)).Copy

    Range(Cells(3, 61), Cells(nod, 101)).PasteSpecial Paste:=xlPasteFormulas

    Application.CutCopyMode = False

    Range("A3").Select

    
    Application.StatusBar = "Processing contact data..."

    
    vcardFile.writeline ("")

    For iRow = 3 To nod

        For iColumn = 61 To 101

            currentValue = Worksheets(mainsheet).Cells(iRow, iColumn).Value

            Application.StatusBar = "Processing contact data " & Round(((iRow - 2) / (nod - 2)) * 100) & "%" '&" on row " & iRow & ", column " & iColumn & ", value: " & currentValue

            If (currentValue <> "no data") Then

                vcardFile.writeline (currentValue)

            End If

            If currentValue = "END:VCARD" Then

                vcardFile.writeline ("")

            End If

        Next iColumn

    Next iRow

    vcardFile.Close

    Application.StatusBar = "All " & nod - 2 & " contact data processed"

    
    Worksheets(mainsheet).Range(Cells(2, 61), Cells(nod, 101)).ClearContents

    Worksheets(mainsheet).Range("A3").Select

    end_time = Now()

    'DateDiff("s", start_time, end_time)

    Application.StatusBar = "vCard export in " & PrintHrMinSec(DateDiff("s", start_time, end_time)) & "sec done into file: " & vcardname

    Application.ScreenUpdating = True

    
    If (nod - 2 = 1) Then

        popup = MsgBox(nod - 2 & " contact is exported to:" & vbLf & "'" & vcardname & "'" & vbLf & vbLf & "Please send this file to your phone and run it in order to add this contact into it." & vbLf & vbLf & "Original development 'Desktop Contacts v0.8' by Savas Geivanidis (aki@egnatia.ee.auth.gr)" & vbLf & vbLf & "Major layout and performance improvements myT in 'vCard Exporter v1.0' - http://myTselection.blogpsot.com", vbInformation + vbOKOnly + vbMsgBoxSetForeground, "vCard Exporter: data exported")

    Else

        popup = MsgBox(nod - 2 & " contacts were exported to:" & vbLf & "'" & vcardname & "'" & vbLf & vbLf & "Please send this file to your phone and run it in order to add these contacts into it." & vbLf & vbLf & "Original development 'Desktop Contacts v0.8' by Savas Geivanidis (aki@egnatia.ee.auth.gr)" & vbLf & vbLf & "Major layout and performance improvements myT in 'vCard Exporter v1.0' - http://myTselection.blogpsot.com"", vbInformation + vbOKOnly + vbMsgBoxSetForeground, "vCard Exporter: data exported")

    End If

    Application.DisplayStatusBar = True

End Sub

'*********************** 
  
'* This function calculates hours, minutes

'* and seconds based on how many seconds

'* are passed in and returns a nice format

Public Function PrintHrMinSec(elap)

  Dim hr

  Dim min

  Dim sec

  Dim remainder

  
  elap = Int(elap) 'Just use the INTeger portion of the variable

  
  'Using "\" returns just the integer portion of a quotient

  hr = elap \ 3600 '1 hour = 3600 seconds

  remainder = elap - hr * 3600

  min = remainder \ 60

  remainder = remainder - min * 60

  sec = remainder

  
  'Prepend leading zeroes if necessary

  If Len(sec) = 1 Then sec = "0" & sec

  If Len(min) = 1 Then min = "0" & min

  
  'Only show the Hours field if it's non-zero

  If hr = 0 Then

     PrintHrMinSec = min & ":" & sec

  Else

     PrintHrMinSec = hr & ":" & min & ":" & sec

  End If

  
End Function

Babylon - Contacts

I'm a big fan of Babylon to easily translate or explain something. I also use it a lot with my own created "dictionaries". For example: I made some script to easily export all my Microsoft Outlook contacts and create a Babylon dictionary out of it. Whenever I need a name, email, phone number, ... of some contact, I just have to provide a name, company, phone number,... to immediately popup my contacts details with just a click.

Follow these steps if you want to be able to export your own Outlook contacts to Babylon.

1. Export MS Outlook contacts to Excel file: Menu 'File' -> 'Import and export' -> 'Export to file' -> 'Microsoft Excel 97-2003' -> 'Contacts' -> chose some location to save the file
2. Open the generated Excel file
3. Add a new macro in the Excel file: Menu 'Developer' -> 'Visual Basic' -> Sheet1 -> Copy-paste my macro from here :

Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
  "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Type OPENFILENAME
  lStructSize As Long
  hwndOwner As Long
  hInstance As Long
  lpstrFilter As String
  lpstrCustomFilter As String
  nMaxCustFilter As Long
  nFilterIndex As Long
  lpstrFile As String
  nMaxFile As Long
  lpstrFileTitle As String
  nMaxFileTitle As Long
  lpstrInitialDir As String
  lpstrTitle As String
  flags As Long
  nFileOffset As Integer
  nFileExtension As Integer
  lpstrDefExt As String
  lCustData As Long
  lpfnHook As Long
  lpTemplateName As String
End Type
Sub ConvertOutlookContactsToBabylon()
    sFile = "C:\Contacts.gls"
    
    Application.ScreenUpdating = False
    ' turns off screen updating
    Application.DisplayStatusBar = True
    ' makes sure that the statusbar is visible
    Application.StatusBar = "Preparing babylon file in " + sFile
    
    '--------------------------------------------------------------------------
    'Create export file
    '--------------------------------------------------------------------------
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.CreateTextFile(sFile, True)
    f.writeline ("### Glossary title:Contacts")
    f.writeline ("### Author:")
    f.writeline ("### Description:Contacts")
    f.writeline ("### Source language:Dutch")
    f.writeline ("### Source alphabet:Latin")
    f.writeline ("### Target language:Dutch")
    f.writeline ("### Target alphabet:Latin")
    f.writeline ("### Icon:")
    f.writeline ("### Icon2:")
    f.writeline ("### Browsing enabled?Yes")
    
    f.writeline ("### Type of glossary:00000000")
    f.writeline ("### Case sensitive words?0")
    f.writeline ("; DO NOT EDIT THE NEXT **SIX** LINES  - Babylon-Builder generated text !!!!!!")
    f.writeline ("### Glossary id:029f645f6877899f836e9c869d8a89447c6e8e9e8271769a9d659559957889978372869c8477772a9693897f5d89526e7c458944648127444854575a428a9244977c946e5b524147584c559fcc23264eac62515a414f4b8b279a224f5a42474f5f555638993bd86e5b524147584c559f908e2d60475e5a4b597e66833a32294d48429a4d5955")
    f.writeline ("### Confirmation string:7C221QRF")
    f.writeline ("### File build number:01292D7C")
    f.writeline ("### Build:")
    f.writeline ("### Glossary settings:00000000")
    f.writeline ("### Gls type:00000001")
    f.writeline ("; DO NOT EDIT THE PREVIOUS **SIX** LINES  - Babylon-Builder generated text !!!!!!")
    f.writeline ("### Part of speech table:")
    f.writeline ("### Private label id:")
    f.writeline ("### Min version:0")
    f.writeline ("### Regular expression:")
    f.writeline ("### Glossary section:")
    'Find a free column to fill with copy
    ' and find the column to copy from
    For iColumn = 1 To 65000
        'Empty column, stop loop
        colName = CStr(Worksheets(1).Cells(1, iColumn).Value)
        If colName = Empty Then
          lastColumn = iColumn
            Exit For
        End If
        
        'Columns to remove
        If colName = "E-mail Type" Or colName = "E-mail Display Name" Or colName = "E-mail 2 Type" Or colName = "E-mail 2 Type" Or colName = "E-mail 2 Display Name" Or colName = "E-mail 3 Type" Or colName = "E-mail 3 Display Name" Or colName = "Gender" Or colName = "Priority" Or colName = "Private" Or colName = "Sensitivity" Then
          Worksheets(1).Columns(iColumn).Delete (xlShiftToLeft)
          iColumn = iColumn - 1
        End If
        
    Next iColumn
    
    
    'go thru all rows
    For iRow = 2 To 65000
    
        'check if last row to do
        If Worksheets(1).Cells(iRow, 2).Value = Empty And Worksheets(1).Cells(iRow, 4).Value = Empty And Worksheets(1).Cells(iRow + 1, 2).Value = Empty And Worksheets(1).Cells(iRow + 1, 4).Value = Empty Then
            Exit For
        End If
        
        'start new line for babylon display data
        Worksheets(1).Rows(iRow + 1).Insert (xlShiftDown)
        'insert empty row between each contact
        Worksheets(1).Rows(iRow + 2).Insert (xlShiftDown)
        
        'output line, will be written to file
        sLine = ""
        
        'babylon subject
        sSubject = ""
        FullName = CStr(Worksheets(1).Cells(iRow, 2).Value) + " " + CStr(Worksheets(1).Cells(iRow, 4).Value) + "|" + CStr(Worksheets(1).Cells(iRow, 4).Value) + " " + CStr(Worksheets(1).Cells(iRow, 2).Value) + "|"
        
        'keep track of column working in, since cells will be deleted but not in header row
        iColumn = 1
        For headerColumn = 1 To (lastColumn - 1)
            If Worksheets(1).Cells(iRow, iColumn).Value <> Empty Then
                
                'convert value to string
                elementValue = CStr(Worksheets(1).Cells(iRow, iColumn).Value)
                
                
                'eleminiate empty birthday dates
                If elementValue = "0/0/00" Then
                    Worksheets(1).Cells(iRow, iColumn).Value = ""
                Else
                    'insert babylon display data
                    displayData = elementValue
                    
                    'convert email addresses to links
                    If InStr(displayData, "@") And (Not InStr(displayData, " ")) Then
                        displayData = "<a href='mailto:" + elementValue + "'>" + elementValue + "</a>"
                    End If
                    
                    'convert web links
                    If Worksheets(1).Cells(1, headerColumn).Value = "WebPage" Then
                        If Not InStr(elementValue, "http://") Then
                            displayData = "<a href='http://" + elementValue + "'>" + elementValue + "</a>"
                        Else
                            displayData = "<a href='" + elementValue + "'>" + elementValue + "</a>"
                        End If
                    End If
                    
                    'convert phone numbers
                    If InStr(Worksheets(1).Cells(1, headerColumn).Value, "Phone") Or InStr(Worksheets(1).Cells(1, headerColumn).Value, "Fax") Then
                        displayData = Replace(Replace(Replace(elementValue, "+31", "+31."), "+33", "+33."), "+32", "+32.")
                    End If
                    
                    
                    'convert categories
                    If Worksheets(1).Cells(1, headerColumn).Value = "Categories" Then
                        displayArray = Split(displayData, ";")
                        displayData = ""
                        For Each sArrayElement In displayArray
                            displayData = displayData + "<a href='bword://" + sArrayElement + "'>" + sArrayElement + "</a> "
                        Next
                    End If
                        
                        
                    'Put display data in sheet
                    Worksheets(1).Cells(iRow + 1, 1).Value = Worksheets(1).Cells(iRow + 1, 1).Value + "<b>" + Worksheets(1).Cells(1, headerColumn).Value + "</b>: " + Replace(Replace(Replace(displayData, vbCrLf, "<br>"), vbCr, "<br>"), ";", ",") + "<br>"
                    
                    
                    'replace vbCrLf vbCr ; with |
                    elementValue = Replace(Replace(Replace(Replace(elementValue, vbCrLf, "|"), vbCr, "|"), ";", "|"), "||", "|")
                    'replace all special character for babylon search data
                    replacedChars = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(elementValue, " ", "|"), ".", "|"), "@", "|"), ":", "|"), ";", "|"), "-", "|"), "/", "|"), "||", "|"), "||", "|"), "|&|", "|"), "|-|", "|"), "|.|", "|"), "|~|", "|"), "|=|", "|")
                    replacedChars = Replace(Replace(Replace(replacedChars, "+31", "0"), "+33", "0"), "+32", "0")
                    
                    If replacedChars <> elementValue Then
                        Worksheets(1).Cells(iRow, iColumn).Value = elementValue + "|" + replacedChars + "|"
                    Else
                        Worksheets(1).Cells(iRow, iColumn).Value = elementValue + "|"
                    End If
                    
                    If headerColumn = 1 Or headerColumn = 2 Or headerColumn = 3 Or headerColumn = 4 Then
                        If sSubject = "" Then
                            sSubject = elementValue
                        Else
                            sSubject = sSubject + " " + elementValue
                        End If
                    End If
                    
                End If
                
                If Worksheets(1).Cells(1, headerColumn).Value <> "Notes" Then
                    sLine = sLine + Worksheets(1).Cells(iRow, iColumn).Value
                End If
                'handle next cell in next loop of For
                iColumn = iColumn + 1
            Else
                'empty column: remove cell and shift other cells left
                'keep track of original cell location to get the heading name of the cell
                'deleting cells is very slow!
                'Worksheets(1).Cells(iRow, iColumn).Delete (xlShiftToLeft)
                
                'handle next cell in next loop of For, not needed if cells are deleted
                iColumn = iColumn + 1
            End If
        Next headerColumn
        
        sSubject = Replace(sSubject, "|", " ")
        
        'writing to file
        
        f.writeline (Replace(sSubject + "|" + FullName + sLine, "||", "|"))
        f.writeline (Replace(CStr(Worksheets(1).Cells(iRow + 1, 1).Value), vbTab, " "))
        f.writeline ("")
        iRow = iRow + 2
    Next iRow
    
    'Close export file
    f.Close
    
    Application.ScreenUpdating = True
    ' turns off screen updating
    Application.DisplayStatusBar = True
    ' makes sure that the statusbar is visible
    MsgBox "Babylon file prepared in " + sFile
End Sub




4. Close Visual Basic editor


5. Run the created Macro: Menu 'Developer' -> 'Macro' –> 'ConvertOutlookContactsToBabylon'


6. A file called 'c:\Contacts.gls' will be created on your C: drive


7. Open BabylonBuilder.exe and open the gls file 'c:\Contacts.gls': Menu 'File' -> 'Open' (The new version of BabylonBuilder can also be used to compile .gls to .bgl)


8. Press 'Edit screen'


9. Press 'Build screen'


10. Press 'Build'


11. A file called 'Contacts.bgl' file will be created, this is the compile Babylon dictionary.


12. Double click the 'Contacts.bgl' file to load it into Babylon


13. Use Babylon to search on any contact and immediately see all contact details.