Bonjour,
version qui prend en compte les ramifications multiples ... comme cité plus haut, exemple :
A > B
B > C
B > D
Sub nomenclature()
Dim compteur()
Dim cel As Range
Dim dico As Object
Set dico = CreateObject("Scripting.Dictionary")
Sheets("DATA").Select
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
Set cel = Columns("B").Find(Cells(i, 1))
If cel Is Nothing Then
dico(Cells(i, 1).Value) = ""
End If
Next
niveaux = 0
ligne = 2
With Sheets("NOMENCLATURE")
On Error Resume Next
.ListObjects(1).DataBodyRange.Delete
On Error GoTo 0
.Range("F1").CurrentRegion.Offset(1, 0).ClearContents
For Each cle In dico.keys
.Cells(ligne, 1) = 1
.Cells(ligne, 2) = cle
ligne = ligne + 1
Next
ligne = 2
Do
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 1) = .Cells(ligne, 2) Then
.Rows(ligne + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
.Cells(ligne + 1, 2) = Cells(i, 2)
.Cells(ligne + 1, 3) = Cells(i, 3)
.Cells(ligne + 1, 1) = .Cells(ligne, 1) + 1
If .Cells(ligne, 1) + 1 > niveaux Then niveaux = .Cells(ligne, 1) + 1
End If
Next
ligne = ligne + 1
Loop While .Cells(ligne, 1) <> ""
End With
ReDim compteur(0 To niveaux + 1)
For j = 0 To niveaux + 1
compteur(j) = 0
Next
Sheets("NOMENCLATURE").Select
For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
Cells(i, Cells(i, 1) + 5) = Cells(i, 2)
Cells(i, 4) = compteur(Cells(i, 1))
For j = 0 To Cells(i, 1)
compteur(j) = compteur(j) + Cells(i, 3)
Next
For j = Cells(i, 1) To niveaux + 1
compteur(j) = 0
Next
Next
Sheets("CALCUL").Select
ActiveSheet.PivotTables("Tableau croisé dynamique1").PivotCache.Refresh
End Sub