Create a list of Email addresses from selecting contacts in Outlook's global contact list

Hi Nimrod,

Can you just not import all contacts into a worksheet tab and than delete the ones you are not interested in, or mark the ones you are interested in. Whether you make the selection in Outlook or in Excel does not make must of a difference in terms of effort. Am I missing something?

Hi again,
I found this code and it does almost exactly what I need.

I have modified the code to put the gathered information and place it into cells on the active worksheet. Does anyone have a way to do this that is more elegant? Also, can anyone tell me how to remove the comma (,) from the end of each contact's details within VBA?

Sub GetEmail()

Dim objWordApp As Object
Dim strCode As String
Dim strAddress As String
Dim lngDoubleCR As Long
Dim wrdarray() As String
Dim a As Integer, b As Integer


'Set up the formatting codes in strCode
strCode = "<PR_DISPLAY_NAME>" & " " & _
          "<PR_POSTAL_ADDRESS>" & " " & _
          "<PR_EMAIL_ADDRESS>"

' As GetAddress is not available in MS Excel, a call to MS Word object
' has been made to borrow MS Word's functionality
Application.DisplayAlerts = False
'On Error Resume Next
' Set objWordApp = New Word.Application
Set objWordApp = CreateObject("Word.Application")
strAddress = objWordApp.GetAddress(, strCode, False, 1, 1, , True, True)
objWordApp.Quit
Set objWordApp = Nothing
On Error GoTo 0
Application.DisplayAlerts = True

' Nothing was selected
If strAddress = "" Then Exit Sub

strAddress = Left(strAddress, Len(strAddress))

    'Eliminate blank paragraphs by looking for two carriage returns in a row
    lngDoubleCR = InStr(strAddress, vbNewLine & vbNewLine)
    Do While lngDoubleCR <> 0
        strAddress = Left(strAddress, lngDoubleCR - 1) & _
                     Mid(strAddress, lngDoubleCR + 1)
        lngDoubleCR = InStr(strAddress, vbNewLine & vbNewLine)
    Loop
    
Range("A2").Select

'paste in information gathered from multiple contact selections and add them to the active worksheet
wrdarray() = Split(strAddress, ",")
b = UBound(wrdarray()) + 1
c = 1
d = 3
e = 0
Do While a <> b
ActiveCell.Value = Split(strAddress)(e)
ActiveCell.Offset(0, 1).Activate
ActiveCell.Value = Split(strAddress)(c)
ActiveCell.Offset(0, 1).Activate
ActiveCell.Value = Split(strAddress)(d)
a = a + 1
ActiveCell.Offset(1, -2).Activate
e = e + 4
c = c + 4
d = d + 4
Loop
End Sub

Thanks again