Bulk Edit Contacts

Change Company Name

If you have two contacts in the same company, Outlook stores the company name twice. If you want to change the company name, you have to do that for each contact in that company.

If you have Outlook XP or newer, this example does the work for you. Once, all the contacts are found, you may also change other properties, of course.

  How to add macros to Outlook

Public Sub ChangeCompanyName()
  Dim sSearch As String
  Dim sFolder As String

  sFolder = "Contacts"

  sSearch = InputBox("Company:")
  If Len(sSearch) Then
    sSearch = "urn:schemas:contacts:o = '" & sSearch & "'"
    Application.AdvancedSearch sFolder, sSearch
  End If
End Sub

Private Sub Application_AdvancedSearchComplete(ByVal SearchObject As Outlook.Search)
  If SearchObject.Results.Count Then
    ChangeNames SearchObject.Results
  End If
End Sub

Private Sub ChangeNames(Results As Outlook.Results)
  Dim obj As Object
  Dim oContact As Outlook.ContactItem
  Dim sNew As String
  Dim i As Long

  sNew = InputBox("New Name:")
  If Len(sNew) Then
    For i = Results.Count To 1 Step -1
      Set obj = Results(i)
      If TypeOf obj Is Outlook.ContactItem Then
        Set oContact = obj
        oContact.CompanyName = sNew
        oContact.Save
      End If
    Next
  End If
End Sub

Change Domain in Email Address

This sample replaces a part of the email address of each contact in the current folder. The variable 'Find' holds the part you want to replace, the variable 'ReplaceBy' holds the new value.

Public Sub ChangeDomainInEmailAddresses()
  Dim Items As Outlook.Items
  Dim Contact As Outlook.ContactItem
  Dim obj As Object
  Dim Find As String
  Dim ReplaceBy As String
  
  Find = "@domain.de"
  ReplaceBy = "@domain.com"
  
  Set Items = Application.ActiveExplorer.CurrentFolder.Items
  For Each obj In Items
    If TypeOf obj Is Outlook.ContactItem Then
      Set Contact = obj
      If InStr(1, Contact.Email1Address, Find, vbTextCompare) Then
        Contact.Email1Address = Replace(Contact.Email1Address, Find, ReplaceBy, , , vbTextCompare)
        Contact.Save
      End If
    End If
  Next
End Sub