Bonsoir tulipe_4, yosraga
Essaie ceci, restitution en Feuil1 préalablement créée
Option Explicit
Sub test()
Dim a, b(), i As Long, n As Long, j As Long, k As Byte
Application.ScreenUpdating = False
a = Sheets("actuel").Range("A1").CurrentRegion.Value
ReDim b(1 To (((UBound(a, 2) - 23) / 2) * (UBound(a, 1) - 1)) + 1, 1 To 24)
n = 1
For j = 2 To 25
b(n, j - 1) = a(1, j)
Next
For i = 2 To UBound(a, 1)
For j = 24 To UBound(a, 2) Step 2
If a(i, j) <> "" Then
n = n + 1
For k = 2 To 23
b(n, k - 1) = a(i, k)
Next
b(n, 23) = a(i, j)
b(n, 24) = a(i, j + 1)
End If
Next
Next
'Restitution et mise en forme en Feuil1
With Sheets("Feuil1")
.Cells.Clear
With .Range("A1").Resize(n, UBound(b, 2))
.Value = b
With .Rows(1)
.BorderAround Weight:=xlThin
.Interior.ColorIndex = 44
.HorizontalAlignment = xlCenter
End With
.Font.Name = "calibri"
.Font.Size = 10
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.VerticalAlignment = xlCenter
'.HorizontalAlignment = xlCenter
.Columns.AutoFit
End With
End With
Application.ScreenUpdating = True
End Sub
klin89