Firstly, I apologise if this has been answered in a related thread. If anyone is able to provide the link, I can leave everyone alone!

I have been trying to edit the code below to reference a shared mailbox with little luck. Using GetSharedDefaultFolder does not place the contacts in the correct folder. The name of the mailbox is "Shipping Business Unit". If anyone can help me out it would be greatly appreciated!

Const DISTLISTNAME As String = "My Dist List"
Const olDistributionListItem = 7
Const olFolderContacts = 10
 
Sub MaintainDistList()
 
' Private Sub Worksheet_Change(ByVal Target As Range)
 
' If Intersect(Target.Address, Range("B:B")) Is Nothing Then
  ' Exit Sub
' End If
 
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) & "<" & arrData(i, 2) & ">")
      '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
 
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