' <DieseOutlookSitzung>
Option Explicit

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

  sFolder = "Kontakte"

  sSearch = InputBox("Company:")
  If Len(sSearch) Then
    ' Exakte Übereinstimmung im Firmennamen suchen
    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

  sNew = InputBox("Neuer Name:")
  If Len(sNew) Then
    For Each obj In Results
      If TypeOf obj Is Outlook.ContactItem Then
        Set oContact = obj
        oContact.CompanyName = sNew
        oContact.Save
      End If
    Next
  End If
End Sub
' </DieseOutlookSitzung>