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
| Option Explicit
Option Compare Text
Sub test()
Dim a, b(), i As Long, n As Long, x As Long, Grp As String
Application.ScreenUpdating = False
With Sheets("Feuil1")
a = .Range("a1", .Range("a" & Rows.Count).End(xlUp)).Value
End With
ReDim b(1 To UBound(a, 1), 1 To 2)
With CreateObject("Scripting.Dictionary")
.comparemode = 1
For i = 1 To UBound(a, 1)
If Left(a(i, 1), 6) = "Groupe" Then Grp = a(i, 1)
If Left(a(i, 1), 6) <> "Groupe" Then
If Not .exists(a(i, 1)) Then
n = n + 1: b(n, 1) = a(i, 1)
.Item(a(i, 1)) = n
End If
x = .Item(a(i, 1))
b(x, 2) = b(x, 2) & IIf(b(x, 2) <> "", ", ", "") & Grp
End If
Next
End With
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Resultat").Delete
Sheets.Add().Name = "Resultat"
On Error GoTo 0
With Sheets("Resultat").Cells(1)
.Resize(n, UBound(b, 2)).Value = b
With .CurrentRegion
.Font.Name = "calibri"
.Font.Size = 11
.VerticalAlignment = xlCenter
.Borders(xlInsideVertical).Weight = xlThin
.BorderAround Weight:=xlThin
.Columns.AutoFit
End With
End With
Application.ScreenUpdating = True
End Sub |
Partager