1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51
| Sub CommandButton1_Click()
Dim i&, j&, X&
Dim D As Object, DTmp As Object, DCode As Object
Dim TReport As Variant, TTmp As Variant, TData As Variant
Dim Code$, Plg As Range
Set D = CreateObject("Scripting.dictionary")
Set DTmp = CreateObject("Scripting.dictionary")
Set DCode = CreateObject("Scripting.dictionary")
ReDim TReport(0)
With Sheets("Feuil1")
Set Plg = .Range(.Cells(2, 1), .Cells(Rows.Count, 5).End(3))
End With
TData = Plg
For i = LBound(TData, 1) To UBound(TData, 1)
If InStr(TData(i, 1), "Sous Total ") = 0 Then
Code = Split(TData(i, 4), "/")(0)
If Not DCode.Exists(Code) Then
ReDim Preserve TReport(1 To UBound(TReport) + 1)
ReDim TTmp(2)
Set TTmp(1) = CreateObject("Scripting.dictionary")
TTmp(2) = Code
TReport(UBound(TReport)) = TTmp
DCode(Code) = UBound(TReport)
End If
Set DTmp = TReport(DCode(Code))(1)
X = DTmp.Count
ReDim TTmp(1 To UBound(TData, 2))
For j = LBound(TData, 2) To UBound(TData, 2)
TTmp(j) = CStr(TData(i, j))
Next j
TReport(DCode(Code))(0) = TReport(DCode(Code))(0) + TData(i, 5)
DTmp(X) = TTmp
Set TReport(DCode(Code))(1) = DTmp
End If
Next i
Application.ScreenUpdating = False
Plg.ClearContents
With Sheets("Feuil1")
For i = LBound(TReport) To UBound(TReport)
Set DTmp = TReport(i)(1)
.Cells(.Rows.Count, 1).End(3)(2).Resize(DTmp.Count, 5).FormulaLocal = Application.Index(DTmp.Items, , 0)
With .Cells(.Rows.Count, 1).End(3)(2)
.Value = "Sous Total " & TReport(i)(2)
.Offset(, 4) = TReport(i)(0)
End With
Next i
End With
End Sub |
Partager