Automatically update Outlook distribution lists from Excel

Kevin writes and asks if there is any procedure that will update a distribution list in Outlook using a list of names and email addresses in Excel. Let's see what we can come up with.

Rather than update an existing distribution list, I prefer to simply delete and recreate the entire list. It's much easier than going through the worksheet and comparing each name against the existing members of the distribution list to see who needs to be added, or some complicated workaround (like a helper column) to "tell" the procedure where to start checking for new names.

We'll start with the event handler and then work on a procedure that can be run on demand.

Event Handler

Assume we have a workbook with one sheet — column A has names, column B has email addresses. The first row is a header row. Place the following code into the sheet module for the worksheet (see "Paste code in a Sheet module" in Where do I paste the code that I want to use in my workbook if you need placement assistance). Whenever the worksheet is updated, you'll be prompted to (re)create the distribution list.

Const DISTLISTNAME As String = "My Dist List"
Const olDistributionListItem = 7
Const olFolderContacts = 10

Private Sub Worksheet_Change(ByVal Target As Range)

Dim outlook As Object ' Outlook.Application
Dim contacts As Object ' Outlook.Items
Dim myDistList As Object ' Outlook.DistListItem
Dim newDistList As Object ' Outlook.DistListItem
Dim objRcpnt As Object ' Outlook.Recipient
Dim arrData() As Variant
Dim rng As Excel.Range
Dim numRows As Long
Dim numCols As Long
Dim i As Long
Dim msg As String

msg = "Worksheet has been changed, would you like to update distribution list?"

  If MsgBox(msg, vbYesNo) = vbNo Then
    Exit Sub
  End If

  Set outlook = GetOutlookApp
  Set contacts = GetItems(GetNS(outlook))

  On Error Resume Next
  Set myDistList = contacts.item(DISTLISTNAME)
  On Error GoTo 0

  If Not myDistList Is Nothing Then
    ' delete it
    myDistList.Delete
  End If

    ' recreate it
    Set newDistList = outlook.CreateItem(olDistributionListItem)

    With newDistList
      .DLName = DISTLISTNAME
      .body = DISTLISTNAME
    End With

    ' loop through worksheet and add each member to dist list
    numRows = Range("A1").CurrentRegion.Rows.count - 1
    numCols = Range("A1").CurrentRegion.Columns.count

    ReDim arrData(1 To numRows, 1 To numCols)

    ' take header out of range
    Set rng = Range("A1").CurrentRegion.Offset(1, 0).resize(numRows, numCols)
    ' put range into array
    arrData = rng.value

    ' assume 2 cols (name and emails only)
    For i = 1 To numRows
      Set objRcpnt = outlook.Session.CreateRecipient(arrData(i, 2))

      objRcpnt.Resolve
      newDistList.AddMember objRcpnt
    Next i

    newDistList.Save
    'newDistList.Display

End Sub

Function GetOutlookApp() As Object
  On Error Resume Next
  Set GetOutlookApp = CreateObject("Outlook.Application")
End Function

Function GetItems(olNS As Object) As Object
  Set GetItems = olNS.GetDefaultFolder(olFolderContacts).items
End Function
Function GetNS(ByRef app As Object) As Object
  Set GetNS = app.GetNamespace("MAPI")
End Function

Change the first line ("My Dist List") to the name of the distribution list you want. When you change anything on the worksheet (i.e. add a new name and email address in cols A and B), the code looks for the named distribution list. If it exists, it's deleted, so make sure you use only the worksheet to maintain the distribution list. Any names you add manually will be gone.

Then the looping begins. Here we can go two ways: If the names are in your Address Book or GAL, you can use

Set objRcpnt = outlook.Session.CreateRecipient(arrData(i, 1))

if you know the names will resolve properly. If not, you should use the code as written, because email addresses will always resolve.

The recipients need to be passed as Recipient Objects, hence the use of CreateRecipient to create a temporary Recipient Object.

We may also want to change the procedure so that it only checks a specific range. For example, if you use the worksheet for other things, you may not want it interrupting you if you aren't actually working on the dist list. Adding this at the top of the above event handler would help:

If Intersect(Target.Address, Range("B:B")) Is Nothing Then
  Exit Sub
End If

On Demand Procedure

This procedure is essentially the same as the event handler, except that this one runs only when you want.

Const DISTLISTNAME As String = "My Dist List"
Const olDistributionListItem = 7
Const olFolderContacts = 10

Sub MaintainDistList()

Dim outlook As Object ' Outlook.Application
Dim contacts As Object ' Outlook.Items
Dim myDistList As Object ' Outlook.DistListItem
Dim newDistList As Object ' Outlook.DistListItem
Dim objRcpnt As Object ' Outlook.Recipient
Dim arrData() As Variant
Dim rng As Excel.Range
Dim numRows As Long
Dim numCols As Long
Dim i As Long

  Set outlook = GetOutlookApp
  Set contacts = GetItems(GetNS(outlook))

  On Error Resume Next
  Set myDistList = contacts.item(DISTLISTNAME)
  On Error GoTo 0

  If Not myDistList Is Nothing Then
    ' delete it
    myDistList.Delete
  End If

    ' recreate it
    Set newDistList = outlook.CreateItem(olDistributionListItem)

    With newDistList
      .DLName = DISTLISTNAME
      .body = DISTLISTNAME
    End With

    ' loop through worksheet and add each member to dist list
    ' assume active sheet
    numRows = Activesheet.Range("A1").CurrentRegion.Rows.count - 1
    numCols = Activesheet.Range("A1").CurrentRegion.Columns.count

    ReDim arrData(1 To numRows, 1 To numCols)

    ' take header out of range
    Set rng = Activesheet.Range("A1").CurrentRegion.Offset(1, 0).resize(numRows, numCols)
    ' put range into array
    arrData = rng.value

    ' assume 2 cols (name and emails only)
    For i = 1 To numRows
      Set objRcpnt = outlook.Session.CreateRecipient(arrData(i, 2))

      objRcpnt.Resolve
      newDistList.AddMember objRcpnt
    Next i

    newDistList.Save
    'newDistList.Display

End Sub

Function GetOutlookApp() As Object
  On Error Resume Next
  Set GetOutlookApp = CreateObject("Outlook.Application")
End Function

Function GetItems(olNS As Object) As Object
  Set GetItems = olNS.GetDefaultFolder(olFolderContacts).items
End Function
Function GetNS(ByRef app As Object) As Object
  Set GetNS = app.GetNamespace("MAPI")
End Function

Here's what a sample spreadsheet would look like:

And here's an Outlook distribution list as a result:

Related Articles:

• September 16, 2009 -- Sharing email addresses in Outlook and an approach to problem-solving
• January 12, 2009 -- Create Distribution Lists for your Contacts