Macro to find contacts by category and copy them to another folder

[TylerK]

Hello,

I'm having trouble finding the answer to my issue and am hoping for some help.

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.

I figured the code would search the main/default folder based on the proper category and would then copy those contacts to another folder. Those filtered contacts would then be exported to csv. I simply can't find the code online.

Any help would be greatly appreciated.

Thanks!

Tyler

 

[Diane Poremsky]

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. http://www.slipstick.com/tutorial/no-export-way-to-use-outlook-data/

If you need to do this often, it might be easier to use a macro and fully automate it., but for infrequent use, copy and paste works great.

I tweaked the CopyAppttoPrint macro on this page to copy the contacts to a subfolder. You need to type in the category name - all lower case should work, but you do need the full category name.

Sub CopyContacts()
   
   Dim ContactsFolder As Outlook.Folder
   Dim DestFolder 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, CopiedItem As ContactItem

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

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

' copy to subfolder
Set DestFolder = ContactsFolder.Folders("Copies")

   ' 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
     

Set CopiedItem = Item.Copy
CopiedItem.Move DestFolder
  
   Next
   ' Display the number of contacts copied
     MsgBox (iNumRestricted & " contacts were copied were"), vbOKOnly, "Copy Contacts"
   Set Item = Nothing
   Set CopiedItem = Nothing
   Set ResItems = Nothing
   Set ContactItems = Nothing
   Set ContactsFolder = Nothing
  
End Sub

 

[TylerK]

Thanks so much for the quick reply!

This will be an exercise that will be done frequently and by several users that aren't very tech savvy. That said, a macro is perfect and what you sent works great! This is greatly appreciated!

I don't mean to take advantage, but if you're up for another favor, I need to troubleshoot a couple more things for this code. Any help would be very much appreciated but I understand that I'm asking for help with a lot of features here.

For the existing code you provided:
1) Prior pasting the contacts that were found into the destination folder, I need to delete the existing contacts in the destination folder or duplicates will be formed.

Export of Contacts from Destination Folder to CSV:
1) I need to export the contacts in that destination folder to a location filled in by the user after being prompted - Or, just the user's desktop if that's easier. In the latter case, if there's a way to auto name the file, that would be really ideal. Something like "OutboundEngine Outlook Export" with Today's date and time.
2) The CSV file is ultimately going to be uploaded to another program's interface that only allows a certain number of columns and with titles in the first row that are different from what Outlook generates. The exported data needs to have column headings as follows:
1) Outlook Output: "E-Mail Address" | Needed for import: "email"
2) Outlook Output: "First Name" | Needed for import: "fname"
3) Outlook Output: "Last Name" | Needed for import: "lname"
4) Outlook Output: "Company" | Needed for import: "company"
5) Outlook Output: "Business Phone"| Needed for import: "phone"
6) Outlook Output: "Birthday" | Needed for import: They require that Birthday be split into numerical values for the day, month and year as follows "bday" "bmonth" "byear". As I understand it, CSV files cannot have formulas so the end result would have to be the value in each cell.
7) Outlook Output: "Notes" | Needed for import: "notes"

Thanks very much and Happy New Year!

 

[Diane Poremsky]

1. The easiest way to is to delete the folder and recreate it. The code can do that -which is probably better as the user won't need to create the folder. However, if they don't empty their deleted folder it can affect the macro.

This would replace the code that sets the parent and the copy folders:

On Error Resume Next

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

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

' copy to subfolder
Set DestFolder = ContactsFolder.Folders("Copies")
DestFolder.Delete
Set DestFolder= objCalendar.Folders.Add("Copies")

To keep the folder and delete the contents, count the items then delete, counting backwards:

' copy to subfolder
Set DestFolder = ContactsFolder.Folders("Copies")

For iNumCount = DestFolder.Items.Count To 1 Step -1
Set Item = DestFolder.Items.Item(iNumCount)
Item.Delete
Next iNumCount
 
  ' Get all of the items in the folder
  Set ContactItems = ContactsFolder.Items

BTW, if there is a possibility of duplicates(which will cause an error), use an on error resume next before the copy:

On Error Resume Next
Set CopiedItem = Item.Copy
CopiedItem.Move DestFolder

 

[Diane Poremsky]

oh, and for the export, i have a macro that writes outlook data to excel - http://www.slipstick.com/developer/code-samples/macro-export-outlook-fields-excel/ but you could write it to a text file, with values command delimited. I think i have code for that too.

 

[Diane Poremsky]

Here is a smaple that will write to a text file.
http://www.slipstick.com/developer/code-samples/save-email-message-text-file/

Delete: Set Folder = Application.ActiveExplorer.CurrentFolder

Add to top: Dim ContactsFolder As Folder


This will write the fields you need

Set ContactsFolder = Session.GetDefaultFolder(olFolderContacts)
Set Folder = ContactsFolder.Folders("Copies")

For Each objItem In Folder.Items ' replaces In ActiveExplorer.Selection

With objFile
    .Write objItem.Email1Address & ";" & objItem.FirstName & ";"
    .Write objItem.LastName & ";" & objItem.CompanyName & ";"
    .Write objItem.BusinessTelephoneNumber & ";"
    .Write Format(objItem.Birthday, "mm") & ";" & Format(objItem.Birthday, "dd") & ";" & Format(objItem.Birthday, "yy") & ";"
    .Write vbCrLf
End With

  Next
  objFile.Close

oh, and if you need double quotes around the fields, use this format:
& ";" & Chr(34) & objItem.CompanyName & Chr(34) & ";"

 

[Diane Poremsky]

BTW, if you don't need to make copies, you can export the filtered contacts in place -

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(), "yyyy-mm-dd")

'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
' ==================

   ' 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 & "," & Item.FirstName & ","
    .Write Item.LastName & "," & Chr(34) & Item.CompanyName & Chr(34) & ","
    .Write Item.BusinessTelephoneNumber & ","
    .Write Format(Item.Birthday, "mm") & "," & Format(Item.Birthday, "dd") & "," & Format(Item.Birthday, "yy") & ","
    .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

 

[TylerK]

Thanks so much!

I'm giving the last suggestion a shot and am running into an issue. The alert says "Compile Error: User-defined type not defined" Then highlights the text that I've underlined below. any thoughts?


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(), "yyyy-mm-dd")

'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
' ==================

' 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 & "," & Item.FirstName & ","
.Write Item.LastName & "," & Chr(34) & Item.CompanyName & Chr(34) & ","
.Write Item.BusinessTelephoneNumber & ","
.Write Format(Item.Birthday, "mm") & "," & Format(Item.Birthday, "dd") & "," & Format(Item.Birthday, "yy") & ","
.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

 

[TylerK]

Just added the Scripting Runtime reference and I believe it's working. I'll test some more and will report back. Thanks so much!

 

[TylerK]

This seems to work great for the most part! I'm not getting the correct birthday-day, birthday-month and birthday-year values. Any suggestions?

Also, is there an easy way to add the appropriate column headings?
1) email
2) fname
3) lname
4) company
5) phone
6) bday
7) bmonth
8) byear
9) notes"

Again, thanks so so much for your help. Very much appreciated.

 

[Diane Poremsky]

Set headers - I did it when i called the code to create the file -

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
' ==================

Add the field names you need and end with the new line code.

on the dates, what are you getting? contacts without dates should return 01,01,01 (or 4501 if using yyyy) - this is because outlook doesn't use null for the date, but 1/1/4501.

if you want a blank field you can use an if statement - either check for a smaller date or use 'not' -

If Not item.Birthday = "1/1/4501" Then


if item.birthday < "01/01/2050" then
.Write Format(Item.Birthday, "mm") & "," & Format(Item.Birthday, "dd") & "," & Format(Item.Birthday, "yy") & ","
else
.write ",,,"
end if

 

[TylerK]

Excellent! that worked great!

Since this exported list is meant to be an email distribution list, is there a way to skip the contacts that don't have emails listed in the emailaddress section?

Thanks!

 

[Diane Poremsky]

use the same method - an if statement

For Each Item In ResItems
iNumRestricted = iNumRestricted + 1
if not item.email1address = "" then
'do the .write stuff
end if
Next

 

[TylerK]

Sub Export_OutboundEngine_Contacts()
'SelfCert Instructions: http://www.howto-outlook.com/howto/selfcert.htm
 
   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 = "OutboundEngine Contacts - " & Format(Now(), "dd-mm-yyyy")

'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 & "\Desktop\" & 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 "bday" & "," & "bmonth" & "," & "byear" & ","
.Write vbCrLf
End With

' ==================

   ' Get all of the items in the folder
  Set ContactItems = ContactsFolder.Items
   'create the Restrict filter
  strCategory = "OutboundEngine"

   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
    If Not Item.Email1Address = "" Then
    .Write Item.Email1Address & ","
    .Write Item.FirstName & ","
    .Write Item.LastName & ","
    .Write Item.CompanyName & ","
    .Write Item.BusinessTelephoneNumber & ","
    '.Write Format(Item.Birthday, "mm") & "," & Format(Item.Birthday, "dd") & "," & Format(Item.Birthday, "yy") & ","
        If Item.Birthday < "01/01/2100" Then
        .Write Format(Item.Birthday, "mm") & "," & Format(Item.Birthday, "dd") & "," & Format(Item.Birthday, "yy") & ","
        Else
        .Write ",,,"
        End If
    .Write vbCrLf
 
    Else
    .Write vbCrLf
    End If
    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

Excellent! I promise this is the last request. With the code I landed on, the contacts that are skipped (b/c they don't have an email address) create an empty line in the output text file. Is there a way to modify the code so that the empty lines don't appear or to sort the output file by last name before it's saved?

Lastly, having trouble figuring out how to autofit the columns in the output text file.

My final code is below:
Thanks!

 

[Diane Poremsky]

on the first question, yes, you just need to order the code correctly.

I think this is the problem:

Else
.Write vbCrLf
End If

Remove that write line. Since you don't want to do anything with the ones that don't have addresses, you don't need the else - it'll just skip them.

You can't autofit columns when opening in notepad - I don't think Excel has an autofit command that would do it on open.

 

[TylerK]

This is great. Thanks very much!