Répertorier infos plusieurs signets_Excel

Option Explicit

Sub Audrey()
Dim Feuille As Worksheet, TablContacts(), Dico As Object, i As Long

Set Dico = CreateObject("Scripting.Dictionary")
If FeuilleExiste(ThisWorkbook, "Liste des contacts") Then Worksheets("Liste des contacts").Delete
For Each Feuille In ThisWorkbook.Worksheets
    With Feuille
        TablContacts = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
        For i = LBound(TablContacts, 1) To UBound(TablContacts, 1)
            If Not Dico.exists(TablContacts(i, 1)) Then Dico.Add TablContacts(i, 1), TablContacts(i, 1)
        Next i
    End With
Next Feuille
ThisWorkbook.Worksheets.Add after:=Sheets(ThisWorkbook.Worksheets.Count)
With ActiveSheet
    .Name = "Liste des contacts"
    .Range("A2").Resize(Dico.Count, 1) = Application.Transpose(Dico.keys)
End With
End Sub

Function FeuilleExiste(wk As Workbook, stFeuille) As Boolean
 On Error Resume Next
 FeuilleExiste = Not (wk.Sheets(stFeuille) Is Nothing)
End Function

Option Explicit

Sub Audrey()
Dim Feuille As Worksheet, i As Long
Dim TablContacts(), DicoNoms As Object
Dim TablPalettes(), DicoPalettes As Object
Dim Sommes(), t

t = Timer
Set DicoNoms = CreateObject("Scripting.Dictionary")
Set DicoPalettes = CreateObject("Scripting.Dictionary")

If FeuilleExiste(ThisWorkbook, "Liste des contacts") Then Worksheets("Liste des contacts").Delete

For Each Feuille In ThisWorkbook.Worksheets
    With Feuille
        TablContacts = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
        For i = LBound(TablContacts, 1) To UBound(TablContacts, 1)
            If Not DicoNoms.exists(TablContacts(i, 1)) Then DicoNoms.Add TablContacts(i, 1), TablContacts(i, 1)
        Next i
        TablPalettes = .Range("B2", .Range("B" & Rows.Count).End(xlUp))
        For i = LBound(TablPalettes, 1) To UBound(TablPalettes, 1)
            DicoPalettes(TablPalettes(i, 1)) = DicoPalettes(TablPalettes(i, 1)) + 1
        Next i
    End With
Next Feuille

ReDim Sommes(1 To DicoNoms.Count, 1 To DicoPalettes.Count)
For Each Feuille In ThisWorkbook.Worksheets
    With Feuille
        For i = 2 To .Range("A" & Rows.Count).End(xlUp).Row
            Sommes(Application.Match(.Cells(i, 1), DicoNoms.keys, 0), Application.Match(.Cells(i, 2), DicoPalettes.keys, 0)) = Sommes(Application.Match(.Cells(i, 1), DicoNoms.keys, 0), Application.Match(.Cells(i, 2), DicoPalettes.keys, 0)) + 1 '.Cells(i, 3).Value
        Next i
    End With
Next Feuille
ThisWorkbook.Worksheets.Add after:=Sheets(ThisWorkbook.Worksheets.Count)
With ActiveSheet
    .Name = "Liste des contacts"
    .Range("A2").Resize(DicoNoms.Count, 1) = Application.Transpose(DicoNoms.keys)
    .Range("B1").Resize(1, DicoPalettes.Count) = DicoPalettes.keys
    .Range("B2").Resize(UBound(Sommes, 1), UBound(Sommes, 2)) = Sommes()
End With
MsgBox "Procédure terminée en : " & Timer - t & " secondes. Tu peux reprendre un café..."
End Sub

Function FeuilleExiste(wk As Workbook, stFeuille) As Boolean
 On Error Resume Next
 FeuilleExiste = Not (wk.Sheets(stFeuille) Is Nothing)
End Function

If FeuilleExiste(ThisWorkbook, "Liste des contacts") Then Worksheets("Liste des contacts").Delete

ThisWorkbook.Worksheets.Add after:=Sheets(ThisWorkbook.Worksheets.Count)
With ActiveSheet
    .Name = "Liste des contacts"