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.
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