Filter and Save Contacts to a CSV File

A user at OutlookForums was looking for a macro to copy contacts to another folder for export:

I'm looking for a way to search my contact folder in Outlook for contacts in a certain category and ultimately export just those contacts into an excel workbook or CSV.

If you don't need to do this often, create a view with the fields you need, filter by category then select all, copy and paste into Excel. See The No-Export way to use Outlook data in Excel for more details on this method.

Of course, if it's something you need to do frequently, it will be easier to use a macro and fully automate the process. I tweaked the CopyAppttoPrint macro to filter the contacts and put it together with Save selected messages to a single text file to filter and save the contacts as a CSV file.

The user will need to type the full category name into the dialog box, but using all lower case letters should work ok. Using partial names like "busin" for "business" won't work.

Note: when a birthdate is not entered, Outlook uses 1/1/4501, not "Null", so any contact with a blank birthdate will show 01 for the birthdate fields. Also, if you need the results wrapped in double quotes, use Chr(34) in the code.

This macro uses the FileScripting Object. You'll need to set a reference to Scripting Runtime in the VB Editor's Tools, References dialog.

Sub SaveContactsinFile()
   
   Dim ContactsFolder As Outlook.Folder
   Dim ContactItems As Outlook.Items
   Dim ResItems As Outlook.Items
   Dim sFilter, strCategory As String
   Dim iNumRestricted As Integer
   Dim Item As ContactItem
   
   Dim objFS As New Scripting.FileSystemObject, objFile As Scripting.TextStream
   Dim strFile As String
   Dim sName As String

' Use the default folder
Set ContactsFolder = Session.GetDefaultFolder(olFolderContacts)

' Use the selected folder
'Set ContactsFolder = Application.ActiveExplorer.CurrentFolder

' ===============
' Get file ready -
Dim enviro As String
enviro = CStr(Environ("USERPROFILE"))
 
' add the current date to the filename
sName = Format(Now(), "yyyymmdd")

 'random number avoids file exists error
   intHigh = 10000
   intLow = 1
 Randomize
   intNumber = Int((intHigh - intLow + 1) * Rnd + intLow)
 
' The folder path you use needs to exist
  strFile = enviro & "\Documents\" & sName & "-" & ContactsFolder & intNumber & ".csv"
   
  Set objFile = objFS.CreateTextFile(strFile, False)
  If objFile Is Nothing Then
    MsgBox "Error creating file '" & strFile & "'.", vbOKOnly + vbExclamation _
      , "Invalid File"
    Exit Sub
  End If
  
   With objFile
    .Write "email" & "," & "fname" & ","
    .Write "lname" & "," & "company" & ","
    .Write "telephone" & ","
    .Write "month" & "," & "day" & "," & "year"
    .Write vbCrLf
 End With
' ==================

   ' Get all of the items in the folder
  Set ContactItems = ContactsFolder.Items
   'create the Restrict filter
  strCategory = InputBox("Enter the category")

   sFilter = "[Categories] = " & strCategory
 
   ' Apply the filter to the collection
   Set ResItems = ContactItems.Restrict(sFilter)
   iNumRestricted = 0
   
   'Loop through the items in the collection.
  For Each Item In ResItems
      iNumRestricted = iNumRestricted + 1
      
  With objFile
    .Write Item.Email1Address & "," & Chr(34) & Item.FirstName & Chr(34) & ","
    .Write Chr(34) & Item.LastName & Chr(34) & "," & Chr(34) & Item.CompanyName & Chr(34) & ","
    .Write Chr(34) & Item.BusinessTelephoneNumber & Chr(34) & ","
    .Write Format(Item.Birthday, "mm") & "," & Format(Item.Birthday, "dd") & "," & Format(Item.Birthday, "yyyy")
    .Write vbCrLf
 End With
 
  Next
  objFile.Close
   
 ' MsgBox "Exported " & iNumRestricted & " contacts.", vbOKOnly + vbInformation, "DONE!"
   
  Set objFS = Nothing
  Set objFile = Nothing
  
   Set Item = Nothing
   Set ResItems = Nothing
   Set ContactItems = Nothing
   Set ContactsFolder = Nothing
   
End Sub