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
Posts
