Réorganiser des données dans un tableau VBA

Option Explicit
Dim coll As Collection, occur As String
Sub tranposer_colonne()
Dim derlig As Long, col_item As Long
Dim lignes As Long, num As Long, nbre As Long

Sheets(2).Cells.ClearContents
Application.ScreenUpdating = False

With Sheets(1)
   .Activate
    derlig = .Range("A65536").End(3).Row
    Set coll = New Collection
    For col_item = 1 To derlig
        On Error Resume Next
        coll.Add .Cells(col_item, 1).Value, CStr(.Cells(col_item, 1))
        On Error GoTo 0
    Next

    lignes = 1
    For num = 1 To coll.Count
        occur = coll(num)
        nbre = Application.CountIf(.Range("A:A"), occur)
            ecrire nbre, lignes, num
        lignes = lignes + nbre
    Next
End With
Sheets(2).Activate

End Sub

Sub ecrire(cptr As Long, ligne As Long, num_o As Long)
Dim der_col As Byte, col As Byte 'integer si XL2007
Dim grp As Long
Dim cellules As String
Dim tablo
 For grp = 0 To cptr - 1
            der_col = Sheets(1).Cells(ligne + grp, 256).End(xlToLeft).Column
                cellules = cellules & occur & " "
                For col = 2 To der_col
                    cellules = cellules & Cells(ligne + grp, col) & " "
                Next
        Next
         tablo = Split(cellules)
        Sheets(2).Cells(num_o, 1).Resize(1, UBound(tablo)) = tablo
        
End Sub