Microsoft 365 VBA : extraire à partir d'excel tous les groupes de contacts d'outlook

Option Explicit
'---------------------------------------------------------------------------------------
' Procedure : ContactsEtGroupesOutlook
' Discussion: https://www.excel-downloads.com/threads/vba-extraire-a-partir-dexcel-tous-les-groupes-de-contacts-doutlook.20041531/
' Date      : 14/02/2020
' Objet     : Récupérer les contacts et groupe de contacts Outlook
'---------------------------------------------------------------------------------------
'
Sub ContactsEtGroupesOutlook()
    Const olFolderContacts As Long = 10

    '
    '  Objets et autres variables Outlook
    Dim oOutlook As Object       ' Application
    Dim oNameSpace As Object     ' Espace de nom (MAPI)
    Dim Contacts As Object       ' Liste des contacts
    Dim Contact As Object        ' Un contact (ContactItem)
    Dim GrpContacts As Object    ' Un groupe de contacts(DistListItem)
    Dim WasRunning As Boolean    ' L'application tournait-elle avant l'appel de la macro
    '
    '
    Dim tblContacts() As String   ' Tableau des contacts
    Dim tblGroupe() As String     ' Tableau des adresses d'un groupe de contact
    Dim colGroupes As Collection  ' Collection de tblGroupe
    '
    ' Variables de fonctionnement
    Dim cpt1 As Long             ' Compteur de boucle sur liste contacts
    Dim cpt2 As Long             ' Compteur de boucle sur membre de groupe
    '
    ' Objets excel
    Dim wsContacts As Worksheet, wsGroupes As Worksheet
    '
    '---------------------------------------------------------------------------------------
    '
    '     1 - Travail sur Outlook
    '
    '---------------------------------------------------------------------------------------
    '
    ' Tenter d'ouvrir l'application Outlook
    On Error Resume Next
    Set oOutlook = GetObject("Outlook.Application")
    WasRunning = Not oOutlook Is Nothing
    On Error GoTo FIN
    If Not WasRunning Then Set oOutlook = CreateObject("Outlook.Application")
    '
    ' Récupérer le namespace idoine
    Set oNameSpace = oOutlook.GetNamespace("MAPI")
    '
    ' Récupérer les contacts du namespace
    Set Contacts = oNameSpace.GetDefaultFolder(olFolderContacts).Items
    '
    ' Boucler sur tous les contacts (groupe ou non)
    For Each Contact In Contacts
        Select Case TypeName(Contact)
        '
        ' Groupe de contacts
        Case "DistListItem"
            Set GrpContacts = Contact
            '
            ' Si premier, créer la collection des groupes
            If colGroupes Is Nothing Then Set colGroupes = New Collection
            '
            ' dimensionner le tableau au nombre de membres du groupe +1
            ReDim tblGroupe(1 To GrpContacts.MemberCount + 1, 1 To 1)
            '
            ' conserver le nom du groupe en indice 1 du tableau
            tblGroupe(1, 1) = GrpContacts.DLName
            '
            ' Parcourrir les membres du groupe et les ajouter au tableau
            For cpt2 = 1 To GrpContacts.MemberCount
                tblGroupe(cpt2 + 1, 1) = GrpContacts.GetMember(cpt2).Address
            Next
            '
            ' Ajouter le tableau à la collection des groupes
            colGroupes.Add tblGroupe
        '
        ' Contact unique
        Case "ContactItem"
            '
            ' Il peut arriver que l'adresse mail ne soit pas renseignée
            If Trim(Contact.Email1Address) <> "" Then
                '
                ' Ajouter le contact au tableau après redimensionnement de ce dernier
                cpt1 = cpt1 + 1
                ReDim Preserve tblContacts(1 To cpt1)
                tblContacts(cpt1) = Trim(Contact.Email1Address)
            End If
        End Select
    Next
    '
    ' Si l'application outlook ne tournait pas avant l'appel de la macro, la quitter proprement
    If Not WasRunning Then oOutlook.Quit
    '
    ' Nettoyer les variables objet Outlook
    Set oNameSpace = Nothing
    Set oOutlook = Nothing
    Set Contacts = Nothing
    '
    '---------------------------------------------------------------------------------------
    '
    '     2 - Retranscription dans les feuilles du classeur
    '
    '---------------------------------------------------------------------------------------
    With ThisWorkbook.Sheets("Groupes")
        .UsedRange.ClearContents
        For cpt1 = 1 To colGroupes.Count
            .Cells(1, cpt1).Resize(UBound(colGroupes.Item(cpt1)), 1) = colGroupes.Item(cpt1)
        Next
        Application.Names.Add "Groupes", .Cells(1, 1).CurrentRegion
    End With

    With ThisWorkbook.Sheets("Contacts")
        .UsedRange.ClearContents
        cpt1 = UBound(tblContacts)
        .Cells(1, 1) = "Contacts"
        .Cells(2, 1).Resize(cpt1, 1) = Application.Transpose(tblContacts)
        '
        ' Ajouter les noms de groupes en entête de tableau
        .Cells(1, 2).Resize(, colGroupes.Count).Value = ThisWorkbook.Sheets("Groupes").Cells(1, 1).Resize(1, colGroupes.Count).Value
        Application.Names.Add "Contacts", .Cells(1, 1).CurrentRegion
        With .Cells(1, 1).CurrentRegion
            With .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1)
                .Formula = "=ISNUMBER(MATCH($A2,OFFSET(Groupes,1,COLUMN()-2,,1),0))*1"
            End With
        End With
    End With
    '
    ' C'est f'i fi n'i ni !
FIN:
    If Err.Number <> 0 Then
       MsgBox "Exécution interrompue en raison de l'erreur suivante: " & vbCrLf & vbCrLf & Err.Description, vbExclamation, "Macro 'ContactsEtGroupesOutlook'"
    End If
End Sub

With .Cells(1, 1).CurrentRegion
            With .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1)
                .Formula = "=ISNUMBER(MATCH($A2,OFFSET(Groupes,1,COLUMN()-2,,1),0))*1"
                .NumberFormat = "ü;;"
                .HorizontalAlignment = xlCenter
                With .Font
                    .Name = "Wingdings"
                    .Size = 16
                End With
            End With
        End With