identifier et lister les 5 premiers d'une base de donnée

Public Sub PartDAEQ()
    Dim a, b, i As Long, j As Long, l As Long, c As Long
    Feuil1.[DB2:EQ6] = ""
    a = Feuil1.[DA2:EQ6]
    b = Feuil1.Range("AK2:CX" & Feuil1.Range("AL65536").End(xlUp).Row)    'pour recherche
    c = 6
    For j = 2 To UBound(a, 2) Step 2
        For i = 1 To UBound(a, 1)
            For l = 1 To UBound(b, 1)
                If b(l, c) = a(i, 1) Then    '1 à 5
                    a(i, j) = b(l, c - 2)
                    a(i, j + 1) = b(l, c - 1)
                    Exit For
                End If
            Next l
        Next i
        c = c + 3
    Next j
    Feuil1.[DA2].Resize(UBound(a, 1), UBound(a, 2)) = a
End Sub

Dim a, famille, lieu ', MonDico As Object

Sub PartEUFI()
    Dim a, i As Long, l As Long, li As Long, c As Long
    a = Feuil1.[EU2:FI23]
    famille = Feuil1.Range("Z2", Feuil1.[Z65000].End(xlUp))
    lieu = Feuil1.Range("AF2", Feuil1.[AF65000].End(xlUp))

    For j = 2 To UBound(a, 2)
        For i = 2 To UBound(a, 1)
            a(i, j) = CompteItems(CStr(a(i, 1)), CStr(a(1, j)))
        Next i
    Next j

    Feuil1.[EU2].Resize(UBound(a, 1), UBound(a, 2)) = a
End Sub

Function CompteItems(x As String, y As String) As Long
Dim i As Long
   
        For i = 1 To UBound(famille, 1)
    If famille(i, 1) = x And lieu(i, 1) = y Then CompteItems = CompteItems + 1
    Next i
   
End Function

Sub RechercheEtabFamille()
    Dim a, i As Long, DicoFamille As New Dictionary, DicoEtabFam As New Dictionary

    a = Feuil1.Range("T2:Z" & Feuil1.Range("T65536").End(xlUp).Row)
   
    For i = 1 To UBound(a)
        DicoFamille(a(i, 1)) = a(i, 1)
    Next
    For Each Item In DicoFamille.Items
        For i = 1 To UBound(a)
            If a(i, 1) = Item Then
                DicoEtabFam(a(i, 1) & "-" & a(i, 7)) = DicoEtabFam(a(i, 1) & "-" & a(i, 7)) + 1
            End If
        Next
    Next
    a = DicoEtabFam.Items
    QuickSortDes a, LBound(a), UBound(a)
    For i = LBound(a) To 4 '5 1ers
        Feuil1.Range("DA" & i + 2) = a(i)
    Next
End Sub

Sub QuickSortDes(ByRef av As Variant, ByVal iBeg As Long, ByVal iEnd As Long)
' from http://www.vba-programmer.com/Snippe...rt_Single.html
    Dim iLo As Long
    Dim iHi As Long
    Dim Temp As Variant
    Dim vSep As Variant

    iLo = iBeg
    iHi = iEnd
    vSep = av((iBeg + iEnd) / 2)

    Do
        Do While av(iLo) > vSep    ' descending
            iLo = iLo + 1
        Loop

        Do While av(iHi) < vSep    ' descending
            iHi = iHi - 1
        Loop

        If iLo <= iHi Then
            Temp = av(iLo)
            av(iLo) = av(iHi)
            av(iHi) = Temp
            iLo = iLo + 1
            iHi = iHi - 1
        End If
    Loop While iLo <= iHi

    If iBeg < iHi Then QuickSortDes av, iBeg, iHi
    If iLo < iEnd Then QuickSortDes av, iLo, iEnd
End Sub

Option Explicit
Public Ws As Worksheet, a, famille, lieu, Tbl, i As Long, DicoEtabFam As Dictionary

Sub debut()
    Set Ws = Feuil1    'activesheet si tu as un bouton dans chaque feuille
    Tbl = Ws.Range("T2:AF" & Ws.Range("T65536").End(xlUp).Row)
    CompteEtab
    PartEUFI
    PartDAEQ
End Sub

Sub CompteEtab()
    Dim MonDico As New Dictionary    ', c As Range
'  Set MonDico = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Tbl)
        MonDico(Tbl(i, 1)) = MonDico(Tbl(i, 1)) + 1    'Etab
    Next i
    Ws.[ak2].Resize(MonDico.Count, 1) = Application.Transpose(MonDico.keys)
    Ws.[al2].Resize(MonDico.Count, 1) = Application.Transpose(MonDico.items)
    Ws.[al1].Sort Key1:=Ws.[al2], Order1:=xlDescending, Header:=xlYes
End Sub

Sub PartEUFI()
    Dim a, i As Long, j As Long
    a = Ws.[EU2:FI23]
    For j = 2 To UBound(a, 2)
        For i = 2 To UBound(a, 1)
            a(i, j) = CompteItems(CStr(a(i, 1)), CStr(a(1, j)))
        Next i
    Next j
    Ws.[EU2].Resize(UBound(a, 1), UBound(a, 2)) = a
End Sub

Public Sub PartDAEQ()
    Dim a, b, i As Long, j As Long, l As Long, li As Long, c As Long
    Ws.[DB2:EQ6] = ""
    a = Ws.[DB1:EQ6]
    b = Ws.Range("AK2:AK6")    '5 etab pour recherche
    i = 1
    For li = 1 To UBound(b)
        If i < 6 Then i = i + 1
        For j = 1 To UBound(a, 2) Step 2
            a(i, j) = b(li, 1) 'famille
            a(i, j + 1) = CompteEtabFamille(CStr(b(li, 1)), CStr(a(1, j)))
        Next j
    Next li
    Ws.[DB1].Resize(UBound(a, 1), UBound(a, 2)) = a
End Sub

Function CompteItems(x As String, y As String) As Long
    Dim i As Long

    For i = 1 To UBound(Tbl, 1)
        'si etab=x et famille=y alors compte
        If Tbl(i, 7) = x And Tbl(i, 13) = y Then CompteItems = CompteItems + 1
    Next i

End Function

Function CompteEtabFamille(x As String, y As String) As Long
    Dim i As Long

    For i = 1 To UBound(Tbl, 1)
        'si famille=x et lieu=y alors compte
        If Tbl(i, 1) = x And Tbl(i, 7) = y Then CompteEtabFamille = CompteEtabFamille + 1
    Next i

End Function

DicoEtabFam As Dictionary
Dim MonDico As New Dictionary

b = Ws.Range("AK2:AK6")    '5 etab pour recherche