title: Updating Distribution lists in a shared mailbox from Excel
body: <p>I have the following macro that takes a list of email addresses in Excel and creates/updates an Outlook distribution list under the 'My Contacts' section in Outlook.</p>
  
  <p>How can I adapt this code so that it creates/updates the contacts in a shared mailbox called "Shared Test" instead of just on my mailbox?</p>
  
  <pre><code>Const DISTLISTNAME As String = "Test"
  Const olDistributionListItem = 7
  Const olFolderContacts = 10
  
  Sub test() '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
        'little variation on your theme ...
        Set objRcpnt = outlook.Session.CreateRecipient(arrData(i, 1) &amp; "&lt;" &amp; arrData(i, 2) &amp; "&gt;")
        'end of variation
        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
  
  'To My Contacts
  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
  </code></pre>