Sub RegrouperLignes()
Dim ncol%, F As Worksheet, P As Range, tablo, d As Object, i&, ub%, resu(), s, lig&, col%, j%, n&, x$
ncol = 8 'nombre de colonnes
Set F = ActiveSheet
If F.FilterMode Then F.ShowAllData 'si la feuille est filtrée
Set P = F.Range("A1", F.Range("A" & F.Rows.Count).End(xlUp)).Resize(, ncol)
tablo = P.FormulaR1C1
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(tablo)
d(tablo(i, 1)) = d(tablo(i, 1)) + 1 'comptage
Next
If d.Count Then
ub = Application.Max(d.items) * (ncol - 1) + 1
If ub = ncol Then n = d.Count: GoTo 1
ReDim resu(1 To d.Count, 1 To ub)
d.RemoveAll
For i = 1 To UBound(tablo)
If d.exists(tablo(i, 1)) Then
s = Split(d(tablo(i, 1)))
lig = s(0): col = s(1)
d(tablo(i, 1)) = lig & " " & col + ncol - 1
For j = 2 To ncol
If tablo(i, j) = "" Then tablo(i, j) = " "
resu(lig, col + j - 2) = tablo(i, j)
Next j
Else
n = n + 1
d(tablo(i, 1)) = n & " " & ncol + 1 'mémorise la ligne et la colonne
For j = 1 To ncol
If tablo(i, j) = "" Then tablo(i, j) = " "
resu(n, j) = tablo(i, j)
Next j
End If
Next i
'---mise en forme, MFC et restitution---
Application.ScreenUpdating = False
F.Cells.FormatConditions.Delete
For j = 5 To ub Step ncol - 1
P(1, j).Resize(n).NumberFormat = "dd/mm/yyyy"
Next j
F.[A1] = "=IF(MOD(ROW(),2),MOD(Int((COLUMN()-Pas-2)/Pas),2),MOD(Int((COLUMN()-Pas-2)/Pas),2)=0)" 'pour toutes versions
x = Mid(F.[A1].FormulaLocal, 2)
ThisWorkbook.Names.Add "Pas", ncol - 1 'nom défini
With P(1, ncol + 1).Resize(n, ub - ncol)
.FormatConditions.Add xlExpression, Formula1:="=(" & .Cells(1).Address(0, 0) & "<>""""" & ")*" & x
.FormatConditions(1).Interior.Color = 15917529 'bleu
.FormatConditions(1).Borders.Weight = xlThin
.FormatConditions.Add xlExpression, Formula1:="=" & .Cells(1).Address(0, 0) & "<>"""""
.FormatConditions(2).Borders.Weight = xlThin
End With
P.Resize(n, ub) = resu
End If
1 P.Offset(n).Resize(F.Rows.Count - n - P.Row + 1, ub).Delete xlUp 'RAZ en dessous
With F.UsedRange: End With 'actualise la barre de défilement verticale
End Sub