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 58 59 60 61 62 63 64 65
| Sub test()
Dim Tabl1, Tabl2, Equips, Res() As String, Ctr As Long
Dim Tabl, Dico As Object 'table double entrée
Dim ResEquip(), ResOccur() As Long, Plage As Range
Set Dico = CreateObject("Scripting.Dictionary")
Ctr = 0
ReDim Res(3, 1)
ReDim ResEquip(1)
ReDim ResOccur(1)
With Sheets("Feuille_1")
Tabl1 = Application.Transpose(.Range(.[D2], .Cells(.Rows.Count, 4).End(xlUp)))
Tabl2 = Application.Transpose(.Range(.[E2], .Cells(.Rows.Count, 5).End(xlUp)))
For i = 1 To UBound(Tabl1)
If Not Dico.exists(Tabl1(i) & "***" & Tabl2(i)) Then
Dico.Add Tabl1(i) & "***" & Tabl2(i), Tabl1(i) & "***" & Tabl2(i)
End If
Next i
For Each Item In Dico.items
tablo = Split(Item, "***")
Ctr = Ctr + 1
ReDim Preserve Res(3, Ctr)
Res(1, Ctr) = Item
Res(2, Ctr) = tablo(1)
Res(3, Ctr) = tablo(0)
Next Item
End With
With Sheets("Feuille_5")
.[H:K].ClearContents
.[H2].Resize(UBound(Res, 2), 3).NumberFormat = "@"
.[H2].Resize(UBound(Res, 2), 3) = Application.Transpose(Res)
Set Plage = .Range(.[H2], .Cells(.Rows.Count, 10).End(xlUp))
Plage.Sort key1:=.[I2], order1:=xlAscending, key2:=.[J2], order2:=xlAscending, Header:=xlNo
Tabl = Application.Transpose(.Range(.[H2], .Cells(.Rows.Count, 8).End(xlUp)))
ReDim ResOccur(Dico.Count)
For i = 1 To UBound(Tabl1)
Ctr = Application.Match(Tabl1(i) & "***" & Tabl2(i), Tabl, 0)
ResOccur(Ctr) = ResOccur(Ctr) + 1
Next
.[K2].Resize(UBound(ResOccur)) = Application.Transpose(ResOccur)
.[H:H].ClearContents
Dim Final()
ReDim Final(3, 1)
Ctr = 0
Tabl = Application.Transpose(.Range(.[I2], .Cells(.Rows.Count, 11).End(xlUp)))
For i = 1 To UBound(Tabl, 2)
Ctr = Ctr + 1
ReDim Preserve Final(3, Ctr)
Final(1, Ctr) = Tabl(1, i)
Final(2, Ctr) = Tabl(2, i)
Final(3, Ctr) = Tabl(3, i)
If i < UBound(Tabl, 2) Then
If Tabl(1, i) <> Tabl(1, i + 1) Then
Ctr = Ctr + 1
ReDim Preserve Final(3, Ctr)
End If
End If
Next
For i = UBound(Final, 2) To 2 Step -1
If Final(1, i) = Final(1, i - 1) Then Final(1, i) = ""
Next
.[H:K].Clear
.[I2].Resize(UBound(Final, 2), 2).NumberFormat = "@"
.[I2].Resize(UBound(Final, 2), 3) = Application.Transpose(Final)
End With
End Sub |