Private Sub copyDistroList()

On Error GoTo errHandler

    Dim myOlApp As New Outlook.Application
    Dim myNameSpace As Outlook.NameSpace
    Dim myFolder As Outlook.MAPIFolder
    Dim myDistList As Outlook.DistListItem  'source distribution list contains all contacts
    Dim myDistList1 As Outlook.DistListItem 'target distribution list containing contacts A-L
    Dim myDistList2 As Outlook.DistListItem 'target distribution list containing contacts M-Z
    Dim myFolderItems As Outlook.Items
    Dim myRcpnt As Outlook.Recipient
    
    Dim intIterateContactItems As Integer   'track contact items
    Dim intIterateDLMemberItems As Integer  'track distribution members
    Dim intCountContactItems As Integer     'count contact items
    Dim intCountDLMemberItems As Integer    'count distribution members within list
    
    Dim strSourceDistList As String         'source distro list name container
    Dim strTargetDistList1 As String        'target 1 distro list name container
    Dim strTargetDistList2 As String        'target 2 distro list name container
    Dim blnListFound As Boolean             'track if source distro list was found
    
    strSourceDistList = "test"          'name of source distro list
    strTargetDistList1 = "test1"        'name of target 1 distro list
    strTargetDistList2 = "test2"        'name of target 2 distro list
    
    'create Outlook objects
    Set myNameSpace = myOlApp.GetNamespace("MAPI")
    Set myFolder = myNameSpace.GetDefaultFolder(olFolderContacts)
    Set myFolderItems = myFolder.Items
    Set myDistList1 = myOlApp.CreateItem(olDistributionListItem)
    Set myDistList2 = myOlApp.CreateItem(olDistributionListItem)
    
    'intialize variables
    myDistList1.DLName = strTargetDistList1
    myDistList2.DLName = strTargetDistList2
    blnListFound = False
    
    'assign the count of all contact items to variable
    intCountContactItems = myFolderItems.Count
    
    'iterate through all Outlook contact items until the source distro list is located
    For intIterateContactItems = 1 To intCountContactItems
    
        'check to see if the contact item is a distribution list type
        If TypeName(myFolderItems.Item(intIterateContactItems)) = "DistListItem" Then
        
            'set the myDistList object as the DistListItem
            Set myDistList = myFolderItems.Item(intIterateContactItems)
            
            'check to see if the distro list is correct source list
            If myDistList.DLName = strSourceDistList Then
            
                'assign the distro list member count to variable
                intCountDLMemberItems = myDistList.MemberCount
                
                'iterate through all members of the distro list
                For intIterateDLMemberItems = 1 To intCountDLMemberItems
                
                    'get the member name, create the recipient, and assign to object variable
                    Set myRcpnt = myOlApp.Session.CreateRecipient(myDistList.GetMember(intIterateDLMemberItems).Address)
                    
                    'ensure the recipient can be resolved in the Exchange director
                    myRcpnt.Resolve
                    
                    'is recipient name resolved?
                    If myRcpnt.Resolved = True Then
                        
                        'get the first character of the recipient's last name (format in our Exchange server is Last, First)
                        Select Case Left(myDistList.GetMember(intIterateDLMemberItems).Name, 1)
                        'if the last name begins with letters between A and L, then add to 1st target distro list
                        Case "A" To "L"
                            myDistList1.AddMember myRcpnt
                        'if the last name begins with letters between M and Z, then add to 2nd target distro list
                        Case Else
                            myDistList2.AddMember myRcpnt
                        End Select
                        
                    'if recipient is not resolved then warn the user and move on to the next distro list member
                    Else
                        MsgBox "Sorry, I could not resolve the email address for " & _
                                myDistList.GetMember(intIterateDLMemberItems).Name & "." & _
                                vbCrLf & "Please write this information down and verify." & _
                                vbCrLf & "I will move on with the list.  Click okay " & _
                                "to continue.", vbOKOnly + vbCritical, "NOT RESOLVED"
                        Resume Next
                    End If

                    'Debug.Print myDistList.GetMember(intIterateDLMemberItems).Name & _
                                ", " & myDistList.GetMember(intIterateDLMemberItems).Address
                
                'get the next member of the distro list
                Next intIterateDLMemberItems
                
                'save the new distro lists
                myDistList1.Save
                myDistList2.Save
                'source distro list was found, so set variable to true
                blnListFound = True
                'since the source distro list is found, there is no need to continue with the contact items iteration
                Exit For
            End If
        End If
        
    'get the next item within Contacts
    Next intIterateContactItems
    
    'raise message box if source distro list was not found
    If blnListFound = False Then
        MsgBox "Your Source Distribution List was not found", vbOKOnly + vbInformation, "DISTRO LIST NOT FOUND"
    End If
    
setAllToNothing:
    'end of subroutine, so ensure all objects are emptied
    If Not myOlApp Is Nothing Then
        Set myOlApp = Nothing
    End If
    
    If Not myNameSpace Is Nothing Then
        Set myNameSpace = Nothing
    End If
    
    If Not myFolder Is Nothing Then
        Set myFolder = Nothing
    End If
    
    If Not myDistList Is Nothing Then
        Set myDistList = Nothing
    End If
    
    If Not myDistList1 Is Nothing Then
        Set myDistList1 = Nothing
    End If
    
    If Not myDistList2 Is Nothing Then
        Set myDistList2 = Nothing
    End If
    
    If Not myFolderItems Is Nothing Then
        Set myFolderItems = Nothing
    End If
    
    If Not myRcpnt Is Nothing Then
        Set myRcpnt = Nothing
    End If
    
    Exit Sub
    
errHandler:
    
    MsgBox Err.Number & " " & Err.Description, vbCritical + vbOKOnly, "ERROR"
    Resume setAllToNothing

End Sub