Option Explicit
Sub test()
Dim a, b(), i As Long, j As Long, n As Long
With Feuil1.Range("b6").CurrentRegion
a = .Value
End With
ReDim b(1 To ((UBound(a, 2) - 11) * (UBound(a, 1) - 1)), 1 To 8)
n = 1
b(n, 1) = a(1, 1): b(n, 2) = a(1, 2)
b(n, 3) = a(1, 3): b(n, 4) = "Data User"
b(n, 5) = a(1, 4): b(n, 6) = a(1, 5)
b(n, 7) = a(1, 6): b(n, 8) = a(1, 7)
For i = 2 To UBound(a, 1)
For j = 12 To UBound(a, 2) Step 2
If Not IsEmpty(a(i, j)) Then
n = n + 1
b(n, 1) = a(i, 1): b(n, 4) = a(i, j)
b(n, 5) = a(i, 4): b(n, 6) = a(i, 5)
b(n, 7) = a(i, 6): b(n, 8) = a(i, 7)
End If
Next
Next
'Restitution
With Feuil4.Cells(1)
.CurrentRegion.Clear
With .Resize(n, 8)
.FormulaLocal = b
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
With .Rows(1)
.BorderAround Weight:=xlThin
.Interior.ColorIndex = 36
.Font.Size = 11
End With
.Columns(6).NumberFormat = "h:mm"
.Columns(8).NumberFormat = "h:mm"
.Columns.ColumnWidth = 12
.Parent.Activate
End With
End With
End Sub