C
cinnamngrl
I wrote this macro to remove duplicates. You need to "Show Office
Assistant" in the help menu to display balloon. This macro is run in
visual basic editor.
It is slow and limited. It goes one by one and you can select one to
delete but I would like to work on combining/updating contact info. I
am posting it to get some suggestions.
Sub doubselect()
Set olApp = CreateObject("Outlook.Application")
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set allcontacts = myNameSpace.GetDefaultFolder(olFolderContacts).Items
Debug.Print allcontacts.Count & " Contacts in total"
allcontacts.Sort "[LastName]"
For Each itm In allcontacts
funame = itm.FullName
Set dbcontacts = allcontacts.Restrict("[FullName]= """ & funame &
"""")
If dbcontacts.Count > 1 Then
Debug.Print dbcontacts.Count & " of " & itm
Dim who(1 To 10, 1 To 6)
x = 0
For Each db In dbcontacts
x = x + 1
who(x, 1) = db.BusinessTelephoneNumber
who(x, 2) = db.HomeTelephoneNumber
who(x, 3) = db.Email1Address
who(x, 4) = db.CreationTime
who(x, 5) = db.User1
who(x, 6) = db.FullName
Next
If x > 5 Then x = 5
Set inq = Assistant.NewBalloon
With inq
.Heading = "Available in Contacts for " & funame
.Text = "Select one to delete"
For i = 1 To x
.Labels(i).Text = "name " & dbcontacts(i) & Chr(13) & "work # " &
who(i, 1) & Chr(13) & "home # " & who(i, 2) & Chr(13) & "email " & who
(i, 3) & Chr(13) & "added " & who(i, 4) & Chr(13) & "user1 " & who(i,
5) & Chr(13) & Chr(13)
Next
.Button = msoButtonSetOK
Debug.Print where
End With
Select Case inq.Show
Case 1
dbcontacts(1).Delete
Case 2
dbcontacts(2).Delete
Case 3
dbcontacts(3).Delete
Case 4
dbcontacts(4).Delete
Case 5
dbcontacts(5).Delete
Case Else
End Select
End If
Next
End Sub
Assistant" in the help menu to display balloon. This macro is run in
visual basic editor.
It is slow and limited. It goes one by one and you can select one to
delete but I would like to work on combining/updating contact info. I
am posting it to get some suggestions.
Sub doubselect()
Set olApp = CreateObject("Outlook.Application")
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set allcontacts = myNameSpace.GetDefaultFolder(olFolderContacts).Items
Debug.Print allcontacts.Count & " Contacts in total"
allcontacts.Sort "[LastName]"
For Each itm In allcontacts
funame = itm.FullName
Set dbcontacts = allcontacts.Restrict("[FullName]= """ & funame &
"""")
If dbcontacts.Count > 1 Then
Debug.Print dbcontacts.Count & " of " & itm
Dim who(1 To 10, 1 To 6)
x = 0
For Each db In dbcontacts
x = x + 1
who(x, 1) = db.BusinessTelephoneNumber
who(x, 2) = db.HomeTelephoneNumber
who(x, 3) = db.Email1Address
who(x, 4) = db.CreationTime
who(x, 5) = db.User1
who(x, 6) = db.FullName
Next
If x > 5 Then x = 5
Set inq = Assistant.NewBalloon
With inq
.Heading = "Available in Contacts for " & funame
.Text = "Select one to delete"
For i = 1 To x
.Labels(i).Text = "name " & dbcontacts(i) & Chr(13) & "work # " &
who(i, 1) & Chr(13) & "home # " & who(i, 2) & Chr(13) & "email " & who
(i, 3) & Chr(13) & "added " & who(i, 4) & Chr(13) & "user1 " & who(i,
5) & Chr(13) & Chr(13)
Next
.Button = msoButtonSetOK
Debug.Print where
End With
Select Case inq.Show
Case 1
dbcontacts(1).Delete
Case 2
dbcontacts(2).Delete
Case 3
dbcontacts(3).Delete
Case 4
dbcontacts(4).Delete
Case 5
dbcontacts(5).Delete
Case Else
End Select
End If
Next
End Sub