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
| Type DoubleInV
Nb As Long
A() As String
B() As String
End Type
Sub test()
Dim Idx As Long, L As Long, R As Range, Sh As Worksheet
Dim DblInV() As DoubleInV, Dico
Set Dico = CreateObject("Scripting.dictionary")
ReDim DblInV(0)
Set Sh = Sheets("Feuil1")
Idx = Sh.Range("A" & Cells.Rows.Count).End(xlUp).Row
Set R = Sh.Range(Sh.Range("A1"), Sh.Cells(Idx, 3))
Idx = 0
For L = 1 To R.Rows.Count
If Dico.Exists(R(L, 1).Value & "_" & R(L, 3).Value) = False Then
Idx = Idx + 1
Dico.Add R(L, 1).Value & "_" & R(L, 3).Value, Idx
If Dico.Exists(R(L, 3).Value & "_" & R(L, 1).Value) = False Then Dico.Add R(L, 3).Value & "_" & R(L, 1).Value, Idx
ReDim Preserve DblInV(Idx)
End If
ReDim Preserve DblInV(Dico(R(L, 1).Value & "_" & R(L, 3).Value)).A(DblInV(Dico(R(L, 1).Value & "_" & R(L, 3).Value)).Nb)
ReDim Preserve DblInV(Dico(R(L, 1).Value & "_" & R(L, 3).Value)).B(DblInV(Dico(R(L, 1).Value & "_" & R(L, 3).Value)).Nb)
DblInV(Dico(R(L, 1).Value & "_" & R(L, 3).Value)).A(DblInV(Dico(R(L, 1).Value & "_" & R(L, 3).Value)).Nb) = R(L, 1).Value
DblInV(Dico(R(L, 1).Value & "_" & R(L, 3).Value)).B(DblInV(Dico(R(L, 1).Value & "_" & R(L, 3).Value)).Nb) = R(L, 3).Value
DblInV(Dico(R(L, 1).Value & "_" & R(L, 3).Value)).Nb = DblInV(Dico(R(L, 1).Value & "_" & R(L, 3).Value)).Nb + 1
Next
For L = 1 To UBound(DblInV)
If DblInV(L).Nb > 1 Then
Idx = Sh.Range("D" & Cells.Rows.Count).End(xlUp).Row + 1
If Idx = 2 Then Idx = 1
Sh.Range(Sh.Cells(Idx, "D"), Sh.Cells(Idx, "D").Offset(DblInV(L).Nb - 1)) = Application.WorksheetFunction.Transpose(DblInV(L).A)
Sh.Range(Sh.Cells(Idx, "E"), Sh.Cells(Idx, "E").Offset(DblInV(L).Nb - 1)) = Application.WorksheetFunction.Transpose(DblInV(L).B)
End If
Next
End Sub |
Partager