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 52 53 54 55 56 57
| Sub Macro1()
Dim O As Worksheet
Dim TV As Variant
Dim D As Object
Dim TMP As Variant
Dim I As Integer
Dim TT() As Variant
Set O = Worksheets("Feuil1")
O.Range("D1").CurrentRegion.Clear
O.Range("G1").CurrentRegion.Clear
TV = O.Range("A1").CurrentRegion
Set D = CreateObject("Scripting.Dictionary")
For I = 2 To UBound(TV)
D(TV(I, 1)) = D(TV(I, 1)) + 1
Next I
TMP = D.keys
ReDim TT(0 To UBound(TMP), 1 To 2)
For j = 0 To UBound(TMP)
T = 0
For I = 2 To UBound(TV, 1)
If TV(I, 1) = TMP(j) Then
TT(j, 1) = TMP(j)
TT(j, 2) = TT(j, 2) + TV(I, 2)
End If
Next I
Next j
O.Range("D1").Value = "Produit"
O.Range("E1").Value = "Occurrence"
O.Range("D2").Resize(D.Count, 1) = Application.Transpose(D.keys)
O.Range("E2").Resize(D.Count, 1) = Application.Transpose(D.items)
ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("E:E"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Feuil1").Sort
.SetRange O.Range("D1").CurrentRegion
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
O.Range("G1").Value = "Produit"
O.Range("H1").Value = "Dépense"
O.Range("G2").Resize(D.Count, 2).Value = TT
ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("H:H"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Feuil1").Sort
.SetRange O.Range("G1").CurrentRegion
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub |
Partager