Sub Regrouper()
Dim tablo, ub&, d As Object, i&, rest$(), a, txt$, j As Byte, t$, k&
tablo = Range("B2", Range("H" & Rows.Count).End(xlUp))
ub = UBound(tablo)
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To ub 'liste des entreprises sans doublon
If tablo(i, 7) <> "" Then d(tablo(i, 7)) = ""
Next
ReDim rest(d.Count - 1, 6) 'base 0
a = d.keys
For i = 0 To UBound(a)
txt = a(i)
rest(i, 0) = txt
For j = 1 To 6
t = ""
For k = 1 To ub
If tablo(k, 7) = txt Then
If tablo(k, j) <> "" Then t = t & vbLf & tablo(k, j)
End If
Next
rest(i, j) = Mid(t, 2)
Next
Next
'---restitution---
With Sheets("Regroupe")
.Rows("2:" & .Rows.Count).Delete 'RAZ
With .[A2].Resize(d.Count, 7)
.Value = rest
.WrapText = True 'renvoi à la ligne
.Rows.AutoFit 'ajustement automatique
End With
.Activate
End With
End Sub