Sunday, December 8, 2013

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

No comments:

Post a Comment