Réorganisation de base de données de colonne

Sub RegrouperParEntreprises()
Dim liste As Object
Dim fin As Long, Cptr As Long, Lign As Long
Dim Col As Byte
Dim entree As String, texteRecherche As String, memAdresse As String
Dim tablo
Dim tabloSh2
Dim num As Variant
Dim zoneRecherche As Range, celluleRecherche As Range

Set liste = CreateObject("scripting.dictionary")
'Remplit le dictionnaire avec les valeurs déjà présentes en Feuil2
With Sheets(2)
    fin = .Columns("A").Cells(.Cells.Rows.Count, "A").End(xlUp).Row
    If fin > 2 Then
        tabloSh2 = .Range("A2:A" & fin).Value
        For Cptr = 1 To UBound(tabloSh2)
            entree = tabloSh2(Cptr, 1)
            If Not liste.exists(entree) Then liste.Add entree, entree
        Next
    End If
End With

Lign = 2 'ligne de début de restitution Feuil2
With Sheets(1)
    fin = .Range("B" & Rows.Count).End(xlUp).Row
    tablo = .Range("B2:B" & fin).Value
    For Cptr = 1 To UBound(tablo)
        entree = tablo(Cptr, 1)
        If Not liste.exists(entree) Then
            liste.Add entree, entree
            Sheets(2).Cells(Lign, 1) = entree
            Lign = Lign + 1
            Set celluleRecherche = .Range("B2:B" & fin).Find(entree, , xlValues, xlWhole)
            If celluleRecherche Is Nothing Then
                'inutile car l'entree va forcément être trouvée
                MsgBox "L'entreprise : " & entree & " n'a pas pu être trouvée."
            Else
                memAdresse = celluleRecherche.Address
                Do
                    Col = Sheets(2).Range("IV" & Lign - 1).End(xlToLeft).Offset(0, 1).Column
                    If Col = 2 Then
                        Sheets(2).Cells(Lign - 1, Col) = CStr(.Range(celluleRecherche.Address).Offset(0, 13).Value)
                        Sheets(2).Cells(Lign - 1, Col + 1) = .Range(celluleRecherche.Address).Offset(0, 15).Value
                        Sheets(2).Cells(Lign - 1, Col + 2) = .Range(celluleRecherche.Address).Offset(0, 16).Value
                        Sheets(2).Cells(Lign - 1, Col + 3) = .Range(celluleRecherche.Address).Offset(0, 17).Value
                    Else
                        Sheets(2).Cells(Lign - 1, Col) = .Range(celluleRecherche.Address).Offset(0, 15).Value
                        Sheets(2).Cells(Lign - 1, Col + 1) = .Range(celluleRecherche.Address).Offset(0, 16).Value
                        Sheets(2).Cells(Lign - 1, Col + 2) = .Range(celluleRecherche.Address).Offset(0, 17).Value
                    End If
                    Set celluleRecherche = .Range("B2:B" & fin).FindNext(celluleRecherche)
                Loop Until memAdresse = celluleRecherche.Address
            End If
        End If
    Next
End With
MsgBox "Regroupement terminé. Cf Feuil2"
End Sub

Option Explicit

Sub reorganiser()
Dim Derlig As Long, Cptr As Long
Dim T_pivot, Pivot As Object, Ref As String, Nbre_contact As Byte
Dim Nbre_soc As Long, Liste_ste, liste_contact
Dim T_erp
Dim Lig As Long, Nbre As Byte, Cptr2 As Byte, Col As Byte, Fin As Long
Dim Start As Single

Start = Timer 'par curiosité

With Sheets(1)
     'initialisations
     Derlig = .Columns(1).Find("*", , , , , xlPrevious).Row
     T_pivot = .Range("B2").Resize(Derlig, 1).Value
     Set Pivot = CreateObject("scripting.dictionary")
     ' création de la liste des sociétés avec le nombre de contact
     For Cptr = 1 To UBound(T_pivot) - 1
          Ref = T_pivot(Cptr, 1)
           If Not Pivot.exists(Ref) Then
               Nbre_contact = Application.CountIf(.Columns(2), Ref)
               Pivot.Add Ref, Nbre_contact
          End If
     Next
     Nbre_soc = Pivot.Count
     Liste_ste = Pivot.keys
     liste_contact = Pivot.items
     
     'préparation  du tableau réorganisé en 1 société=1 ligne
     ReDim T_erp(1 To Nbre_soc, 1 To 34)
     For Cptr = 0 To Nbre_soc - 1
          Lig = 1
          Nbre = liste_contact(Cptr)
          For Cptr2 = 1 To Nbre
               Lig = .Columns(2).Find(Liste_ste(Cptr), .Cells(Lig, 2), xlValues).Row
               If Cptr2 = 1 Then
                    For Col = 1 To 19
                         T_erp(Cptr + 1, Col) = Cells(Lig, Col)
                    Next Col
                    Fin = Col
               Else
                    For Col = 17 To 19
                         T_erp(Cptr + 1, Fin) = Cells(Lig, Col)
                         Fin = Fin + 1
                    Next Col
                    
               End If
          Next Cptr2
      Next Cptr
End With

'restitution du tableau final en feuille 2
Application.ScreenUpdating = False
With Sheets(2)
     .Range("A2:AG65000").Clear
     .Range("A2").Resize(Nbre_soc, 34) = T_erp
     .Activate
End With

Application.ScreenUpdating = True
'curiosité personnelle sur 50000 sociétés? merci de le dire
MsgBox "réorganisation effectuée en : " & Timer - Start & "sec."

End Sub