Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNameSpace("MAPI")
Set objContactsFolder = myNameSpace.GetDefaultFolder(10)
Set objContacts = objContactsFolder.Items

   ' Prompt for old and new company names
   strOldCo = InputBox("Enter the category to remove.")
   
   iCount = 0
   
   respond = MsgBox("Begin removing contacts in Category " & stroldCo & " ?", vbOKCancel)
   If respond = 2 Then
      MsgBox "Exiting without removing contacts."
   Else

   ' Process the changes
   For Each objContact In objContacts
      If TypeName(objContact) = "ContactItem" Then
         If (objContact.Categories = strOldCo) or InStr(1,objContact.Categories, ", " & strOldCo)>0 or InStr(1,objContact.Categories, strOldCo & "," )>0Then
            objContact.Delete
            iCount = iCount + 1
         End If
      End If
   Next
   
   MsgBox "Number of contacts removed:" & iCount
   End If
   

   ' Clean up
   Set objContact = Nothing
   Set objContacts = Nothing
   Set objContactsFolder = Nothing