Sub Ventiler()
Dim colTitres As New Collection
Dim colComptes As New Collection
Dim sh As Worksheet
Dim plage As Range
Dim DerLigne As Long
Dim idxTitre As Long
Dim i As Integer, j As Integer
Dim c As Range
Dim Adr1 As String
With Sheets("données")
'Dernière ligne des données
DerLigne = .Range("D" & .Rows.Count).End(xlUp).Row
'Récupère les données de la colTitresonnes D
Set plage = .Range("D2:D" & DerLigne)
End With
'Charger la collection des titre de colonnes
On Error Resume Next
For i = 1 To plage.Rows.Count
colTitres.Add plage.Cells(i, 1), plage.Cells(i, 1)
Next i
On Error GoTo 0
Set plage = Sheets("données").Range("A2:A" & DerLigne)
'Charger la collection des comptes
On Error Resume Next
For i = 1 To plage.Rows.Count
colComptes.Add plage.Cells(i, 1), plage.Cells(i, 1)
Next i
On Error GoTo 0
'Feuille Ventilation
Set sh = Worksheets("Ventilation")
sh.Activate
'Nettoyer les données existantes
sh.Range("A1").CurrentRegion.ClearContents
With sh
'Mettre en A1 le titre
.Range("A1") = "COMPTE"
'Reporter en entête les élements de la collection des titres
For i = 1 To colTitres.Count
.Range("B1").Offset(, i - 1) = colTitres.Item(i)
Next i
.Range("A1").Offset(, colTitres.Count + 1) = "Libellé 2"
j = 0
'Trouver les élement correspondant dans la feuilles données
For i = 1 To colComptes.Count
Set c = plage.Find(what:=colComptes.Item(i), LookIn:=xlValues)
If Not c Is Nothing Then
Adr1 = c.Address
Do
'Incrémentation de la ligne
j = j + 1
'Mettre le numéro de compte
.Cells(1 + j, 1) = colComptes.Item(i)
'Récupère numéro d'index du titre dans la collection
'Le Premier titre est sur la colonne 2 de la feuille
idxTitre = GetidxTitre(colTitres, c.Offset(, 3))
.Cells(1 + j, idxTitre + 1) = c.Offset(, 1)
'Mettre le libellé 2 éventuel
If Not IsEmpty(c.Offset(, 2)) Then
.Cells(1 + j, colTitres.Count + 2) = c.Offset(, 2)
End If
Set c = plage.FindNext(c)
Loop While Not c Is Nothing And c.Address <> Adr1
End If
Next i
' Tri du tableau sur la colonne compte
.Range("A2").Sort Key1:=Range("A2"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End With
End Sub
