Option Explicit
Dim FX As Worksheet, dcol%, nlm&, dlg1&, lg3&, k0%, k1%, k2%
Private Sub Init()
Dim i%: ActiveWindow.Zoom = 70: Columns.ColumnWidth = 9
With Columns(1): .ColumnWidth = 56: .HorizontalAlignment = 2: .IndentLevel = 1: End With
Rows(1).RowHeight = 35.3: Rows(2).RowHeight = 45: [A2] = "Description": Worksheets("CDC").Select
dcol = Cells(3, Columns.Count).End(1).Column: k1 = (dcol - 2) \ 4
With FX
For i = 1 To k1 + 1: .Cells(2, i + 1) = "quantité" & vbLf & "fichier " & i: Next i
i = i + 1: .Cells(2, i) = "total": .Columns(i).ColumnWidth = 7: k0 = k1 + 3
With .Columns(2).Resize(, k0): .HorizontalAlignment = 4: .IndentLevel = 1: End With
With .[A1].Resize(, k0): .VerticalAlignment = 2: .HorizontalAlignment = 3: .MergeCells = -1: End With
With .[A2].Resize(, k0): .VerticalAlignment = 2: .HorizontalAlignment = 3: End With
.[A1] = "Données après tri": nlm = Rows.Count: dlg1 = Cells(nlm, 1).End(3).Row
Range("A3:B" & dlg1).Copy: .[A3].PasteSpecial Paste:=xlPasteValues: Application.CutCopyMode = 0: k1 = 3: k2 = 5
End With
End Sub
Private Sub DispatchCDC()
Dim Dsc$, Qté As Double, dlg2&, lg2&, lg1&, b As Boolean
With FX
Do While Cells(3, k2) <> ""
dlg2 = Cells(nlm, k2).End(3).Row: lg3 = dlg1
For lg2 = 3 To dlg2
Dsc = Cells(lg2, k2)
If Dsc <> "" Then
Qté = Cells(lg2, k2 + 1): b = 0
For lg1 = 3 To dlg1
If .Cells(lg1, 1) = Dsc Then
.Cells(lg1, k1) = Qté: b = -1
End If
Next lg1
If b = 0 Then
lg3 = lg3 + 1
With .Cells(lg3, 1)
.Value = Dsc: .Offset(, 1) = 0: .Offset(, k1 - 1) = Qté
End With
End If
End If
Next lg2
k1 = k1 + 1: k2 = k2 + 4: dlg1 = lg3
Loop
.Select: [A1].Select
End With
End Sub
Private Sub Val0()
Dim lg1 As Double, i%
For lg1 = 3 To lg3
For i = 3 To k1 - 1
With Cells(lg1, i)
If .Value = "" Then .Value = 0
End With
Next i
Next lg1
End Sub
Sub RegroupementCDC()
On Error GoTo ErrFeuille: Application.ScreenUpdating = 0
Dim lg1&, b As Byte, dc%: Set FX = Worksheets("RésultatCDC")
If b = 0 Then Exit Sub 'la feuille "RésultatCDC" existe déjà !
Call Init: DispatchCDC: Val0
If lg3 > 3 Then [A3].Resize(lg3 - 2, k0 - 1).Sort [A3], 1
dc = FX.Cells(2, Columns.Count).End(xlToLeft).Column
For lg1 = 3 To lg3
With Cells(lg1, k0)
.Value = Application.Sum(Cells(lg1, 2).Resize(, dc - 2))
End With
Next lg1
Exit Sub
ErrFeuille:
Worksheets.Add(, Worksheets(1)).Name = "RésultatCDC"
b = 1: Resume
End Sub
