Updating contact groups in Outlook from an Excel file

Question

I have a sheet in an Excel file with names and email addresses.

I what to go through the sheet and update the Outlook group contacts that corresponds to the headers.

Sub CreateOutlookContactGroups()
    
    Dim olApp As Object
    Dim olNS As Object
    Dim olContacts As Object
    Dim olDistList As Object
    Dim olRecip As Object
    Dim lastRow As Long
    Dim i As Long
    
    'Get Outlook application object
    Set olApp = CreateObject("Outlook.Application")
    Set olNS = olApp.GetNamespace("MAPI")
    Set olContacts = olNS.GetDefaultFolder(10) '10 = olFolderContacts
    
    'Get last row of email addresses
    lastRow = Cells(Rows.Count, "X").End(xlUp).Row
    
    'Loop through each column from E to L in row 4
    For i = 5 To 12 'Columns E to L
        If Range(Cells(4, i), Cells(4, i)).Value <> "" Then 'Check if there is a value in cell
            'Create or Get existing distribution list
            On Error Resume Next
                Set olDistList = olContacts.Items("IPM.DistList." & Range(Cells(4, i), Cells(4, i)).Value)
                If olDistList Is Nothing Then 'Create new distribution list
                    Set olDistList = olContacts.Items.Add("IPM.DistList")
                    olDistList.Save
                    olDistList.Subject = Range(Cells(4, i), Cells(4, i)).Value
                End If
            On Error GoTo 0
            
            'Add each email address from column X to distribution list if there is an "X" in the corresponding cell
            For j = 6 To lastRow 'Row 6 to last row with email addresses
                If Range(Cells(j, i), Cells(j, i)).Value = "X" Then 'Check if there is an "X" in cell
                    Set olRecip = olDistList.AddMember(CStr(Range(Cells(j, "X"), Cells(j, "X")).Value))
                    olDistList.Save
                End If
            Next j
        End If
    Next i
    
    'Release Outlook objects
    Set olRecip = Nothing
    Set olDistList = Nothing
    Set olContacts = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
    
    MsgBox "Kontakt grupper uppdaterrade!"   
End Sub

The code stops running at

Set olRecip = olDistList.AddMember(CStr(Range(Cells(j, "X"), Cells(j, "X")).Value))

and throws a incompatible types fault, but the value is a valid email address.

Answer 1

The DistListItem.AddMember method accepts an instance of the Recipient class to be added to the list. You can use the NameSpace.CreateRecipient method which creates a Recipient object. The name of the recipient can be a string representing the display name, the alias, or the full SMTP email address of the recipient. For example:

Sub AddNewMember() 
 'Adds a member to a new distribution list 
 Dim objItem As Outlook.DistListItem 
 Dim objMail As Outlook.MailItem 
 Dim objRcpnt As Outlook.Recipient 
 
 Set objMail = Application.CreateItem(olMailItem) 
 Set objItem = Application.CreateItem(olDistributionListItem) 
 'Create recipient for distlist 
 Set objRcpnt = Application.Session.CreateRecipient("Eugene Astafiev") // or your email address
 objRcpnt.Resolve 
 objItem.AddMember objRcpnt 
 'Add note to list and display 
 objItem.DLName = "Northwest Sales Manager" 
 objItem.Body = "Regional Sales Manager - NorthWest" 
 objItem.Save 
 objItem.Display 
End Sub

Answer 2

The updated code with changed from Eugene's answer:

Sub CreateOutlookContactGroups2()

Dim olApp As Object
Dim olNS As Object
Dim olContacts As Object
Dim olDistList As Object
Dim olRecip As Object
Dim lastRow As Long
Dim i As Long

'Get Outlook application object
Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
Set olContacts = olNS.GetDefaultFolder(10) '10 = olFolderContacts

'Get last row of email addresses
lastRow = Cells(Rows.Count, "X").End(xlUp).Row

'Loop through each column from E to L in row 4
For i = 5 To 12 'Columns E to L
    If Range(Cells(4, i), Cells(4, i)).Value <> "" Then 'Check if there is a value in cell
        'Create or Get existing distribution list
        On Error Resume Next
            Set olDistList = olContacts.Items("IPM.DistList." & Range(Cells(4, i), Cells(4, i)).Value)
            If olDistList Is Nothing Then 'Create new distribution list
                Set olDistList = olContacts.Items.Add("IPM.DistList")
                olDistList.Save
                olDistList.Subject = Range(Cells(4, i), Cells(4, i)).Value
                olDistList.Save
            End If
        On Error GoTo 0
        
        'Add each email address from column X to distribution list if there is an "X" in the corresponding cell
        For j = 6 To lastRow 'Row 6 to last row with email addresses
            If Range(Cells(j, i), Cells(j, i)).Value = "X" Then 'Check if there is an "X" in cell
                'Set olRecip = olDistList.AddMember(CStr(Range(Cells(j, "X"), Cells(j, "X")).Value))
                Set olRecip = Outlook.Application.Session.CreateRecipient(CStr(Range(Cells(j, "X"), Cells(j, "X")).Value))
                olRecip.Resolve
                olDistList.AddMember olRecip
                olDistList.Save
            End If
        Next j
    End If
    Set olDistList = Nothing
Next i

'Release Outlook objects
Set olRecip = Nothing
Set olDistList = Nothing
Set olContacts = Nothing
Set olNS = Nothing
Set olApp = Nothing

MsgBox "Kontakt grupper uppdaterade!"

End Sub