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

Status
Not open for further replies.

TylerK

Member
Outlook version
Outlook 2010 64 bit
Email Account
Exchange Server 2010
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
 
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.

Code:
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
 
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!
 
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:
Code:
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:

Code:
' 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:
Code:
On Error Resume Next
Set CopiedItem = Item.Copy
CopiedItem.Move DestFolder
 
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
Code:
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) & ";"
 
BTW, if you don't need to make copies, you can export the filtered contacts in place -


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(), "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
 
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
 
Just added the Scripting Runtime reference and I believe it's working. I'll test some more and will report back. Thanks so much!
 
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.
 
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
 
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!
 
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
 
Code:
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!
 
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.
 
This is great. Thanks very much!
 
Status
Not open for further replies.
Similar threads
Thread starter Title Forum Replies Date
mrrobski68 Issue with Find messages in a conversation macro Outlook VBA and Custom Forms 1
L Moving emails with similar subject and find the timings between the emails using outlook VBA macro Outlook VBA and Custom Forms 1
X Custom icon (not from Office 365) for a macro in Outlook Outlook VBA and Custom Forms 1
X Run macro automatically when a mail appears in the sent folder Using Outlook 5
G Creating Macro to scrape emails from calendar invite body Outlook VBA and Custom Forms 6
M Use Macro to change account settings Outlook VBA and Custom Forms 0
J Macro to Reply to Emails w/ Template Outlook VBA and Custom Forms 3
C Outlook - Macro to block senders domain - Macro Fix Outlook VBA and Custom Forms 1
Witzker Outlook 2019 Macro to seach in all contact Folders for marked Email Adress Outlook VBA and Custom Forms 1
S macro error 4605 Outlook VBA and Custom Forms 0
A Macro Mail Alert Using Outlook 4
J Outlook 365 Outlook Macro to Sort emails by column "Received" to view the latest email received Outlook VBA and Custom Forms 0
J Macro to send email as alias Outlook VBA and Custom Forms 0
M Outlook Macro to save as Email with a file name format : Date_Timestamp_Sender initial_Email subject Outlook VBA and Custom Forms 0
Witzker Outlook 2019 Macro GoTo user defined search folder Outlook VBA and Custom Forms 6
D Outlook 2016 Creating an outlook Macro to select and approve Outlook VBA and Custom Forms 0
Witzker Outlook 2019 Macro to send an Email Template from User Defined Contact Form Outlook VBA and Custom Forms 0
Witzker Outlook 2019 Macro to check Cursor & Focus position Outlook VBA and Custom Forms 8
V Macro to mark email with a Category Outlook VBA and Custom Forms 4
M Outlook 2019 Macro not working Outlook VBA and Custom Forms 0
S Outlook 365 Help me create a Macro to make some received emails into tasks? Outlook VBA and Custom Forms 1
Geldner Send / Receive a particular group via macro or single keypress Using Outlook 1
D Auto Remove [EXTERNAL] from subject - Issue with Macro Using Outlook 21
V Macro to count flagged messages? Using Outlook 2
sophievldn Looking for a macro that moves completed items from subfolders to other subfolder Outlook VBA and Custom Forms 7
S Outlook Macro for [Date][Subject] Using Outlook 1
E Outlook - Macro - send list of Tasks which are not finished Outlook VBA and Custom Forms 3
E Macro to block senders domain Outlook VBA and Custom Forms 1
D VBA Macro to Print and Save email to network location Outlook VBA and Custom Forms 1
N VBA Macro To Save Emails Outlook VBA and Custom Forms 1
N Line to move origEmail to subfolder within a reply macro Outlook VBA and Custom Forms 0
Witzker Outlook 2019 Macro to answer a mail with attachments Outlook VBA and Custom Forms 2
A Outlook 2016 Macro to Reply, ReplyAll, or Forward(but with composing new email) Outlook VBA and Custom Forms 0
J Macro to Insert a Calendar Outlook VBA and Custom Forms 8
W Macro to Filter Based on Latest Email Outlook VBA and Custom Forms 6
T Macro to move reply and original message to folder Outlook VBA and Custom Forms 6
D Autosort macro for items in a view Outlook VBA and Custom Forms 2
S HTML to Plain Text Macro - Help Outlook VBA and Custom Forms 1
A Macro to file emails into subfolder based on subject line Outlook VBA and Custom Forms 1
N Help creating a VBA macro with conditional formatting to change the font color of all external emails to red Outlook VBA and Custom Forms 5
S Visual indicator of a certain property or to show a macro toggle Outlook VBA and Custom Forms 2
L Modifying VBA script to delay running macro Outlook VBA and Custom Forms 3
S Macro to extract and modify links from emails Outlook VBA and Custom Forms 3
M Replyall macro with template and auto insert receptens Outlook VBA and Custom Forms 1
L Macro to add Date & Time etc to "drag to save" e-mails Outlook VBA and Custom Forms 17
S Macro for Loop through outlook unread emails Outlook VBA and Custom Forms 2
Globalforester ItemAdd Macro - multiple emails Outlook VBA and Custom Forms 3
S Macro to extract email addresses of recipients in current drafted email and put into clipboard Outlook VBA and Custom Forms 2
Witzker HowTo start a macro with an Button in OL contact form Outlook VBA and Custom Forms 12
Witzker Macro to move @domain.xx of a Spammail to Blacklist in Outlook 2019 Outlook VBA and Custom Forms 7

Similar threads

Back
Top