Option Explicit
Sub test()
Dim r As Range, rng As Range, derlig As Long
Dim i As Long, j As Byte, n As Long
Application.ScreenUpdating = False
Sheets("Feuil1").Cells.Clear
With Sheets("LIVRAISON TRANSPORT")
n = 1: derlig = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 4 To derlig
Set rng = .Range(.Cells(i, 1), .Cells(i, 31))
With rng.Offset(, 1).Resize(, rng.Columns.Count - 1)
On Error Resume Next
Set r = .RowDifferences(.Find("", lookat:=xlWhole))
On Error GoTo 0
End With
If Not r Is Nothing Then
With Sheets("Feuil1")
For j = 1 To r.Areas.Count
n = n + 1
.Cells(n, 1) = rng.Cells(1).Value
.Cells(n, 2) = r.Areas(j)(3 - i, 1)
r.Areas(j).Copy
.Cells(n, 3).PasteSpecial xlPasteValues
Next
End With
End If
Set r = Nothing
Next
With Sheets("Feuil1").Cells(1)
.Resize(1, 8).Value = Array("Usine", "Jour", "S", _
"Propriétaire", "Chantier", "T", "Prod", "V. (st)")
With .CurrentRegion
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
With .Rows(1)
.BorderAround Weight:=xlThin
.Interior.ColorIndex = 38
End With
.Columns.AutoFit
End With
.Parent.Activate
End With
End With
Set rng = Nothing
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub