Ha bon...
J'arrive à mes limites, dsl, même si je m'obstine ...Je vais devoir passer la main
essaye ces 2 codes , il y a une différence 8)
Sub regroupe1()
Dim WS1, Ws2 ' As Worksheets
Set WS1 = Sheets("Requête3")
Set Ws2 = Sheets("groupé")
Ws2.Cells.ClearContents
Set d = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
For Each c In WS1.Range("b2", WS1.[b65000].End(xlUp))
zz = c.Value & " " & c.Offset(0, 1)
If Not d.Exists(zz) Then
d(zz) = c.Offset(0, 8) & " (" & c.Offset(, 9) & ")"
Else
d(zz) = d(zz) & "//" & c.Offset(0, 8) & " (" & c.Offset(, 9) & ")"
End If
Next c
If d.Count = 0 Then Exit Sub
a = d.Keys ' ARRAY
b = d.items ' ARRAY
Ws2.[A1] = "Nom": Ws2.[B1] = "Stages suivis"
Ws2.[A2].Resize(d.Count, 1) = Application.Transpose(d.Keys)
For i = 0 To UBound(a)
For col = 0 To UBound(Split(b(i), "//"))
Ws2.Cells(i + 2, 2).Value = Split(b(i), "//")(col) & Chr(10) & Ws2.Cells(i + 2, 2).Value
Next col
Next i
Ws2.[A2:A1000].Rows.AutoFit
End Sub
et :
Sub regroupe2()
Application.ScreenUpdating = False
Dim WS1, Ws2 ' As Worksheets
Set WS1 = Sheets("Requête3")
Set Ws2 = Sheets("groupé")
Ws2.Cells.ClearContents
Set d = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
For Each c In WS1.Range("a2", WS1.[a65000].End(xlUp))
zz = c.Value & "//" & c.Offset(0, 1) & " " & c.Offset(, 2)
If Not d.Exists(zz) Then
d(zz) = c.Offset(0, 9) & " (" & c.Offset(, 10) & ")"
Else
d(zz) = d(zz) & "//" & c.Offset(0, 9) & " (" & c.Offset(, 10) & ")"
End If
Next c
If d.Count = 0 Then Exit Sub
a = d.Keys ' ARRAY
b = d.items ' ARRAY
Ws2.[A1] = "Nom": Ws2.[B1] = "Noms": Ws2.[C1] = "Stages suivis"
'Ws2.[a2].Resize(D.Count, 1) = Application.Transpose(D.keys)
' splitter société/nom
For i = 0 To UBound(a)
s = Split(a(i), "//")
Ws2.Cells(i + 2, 1) = s(0): Ws2.Cells(i + 2, 2) = s(1)
Next
' splitter les stages
For i = 0 To UBound(a)
For col = 0 To UBound(Split(b(i), "//"))
Ws2.Cells(i + 2, 3).Value = Split(b(i), "//")(col) & Chr(10) & Ws2.Cells(i + 2, 3).Value
Next col
Next i
Ws2.[A2:A1000].Rows.AutoFit
End Sub