Sub PlusDeLignes()
Dim xinit, xcompte, xrg As Range, i&, j&
Application.ScreenUpdating = False
With Sheets("Initial")
xinit = .Range(.Range("a2"), .Range("e" & .Range("a" & Rows.Count).End(xlUp).Row)).Value
xcompte = .Range(.Range("g2"), .Range("g" & .Range("g" & Rows.Count).End(xlUp).Row)).Value
End With
With Sheets("Attendu")
Set xrg = .Range("a2")
.Range("a2:d" & Rows.Count).Clear
.Range("h2:j" & Rows.Count).Clear
For i = LBound(xinit) To UBound(xinit)
xrg.Resize(3) = xinit(i, 1)
xrg.Offset(, 1).Resize(3) = xinit(i, 2)
For j = 0 To 2
xrg.Offset(j, 2) = xcompte(j + 1, 1)
xrg.Offset(j, 3) = xinit(i, j + 3)
Next j
For j = 0 To 2
xrg.Offset(, j + 7) = xinit(i, j + 3)
Next j
Set xrg = xrg.Offset(3)
Next i
.Range("a1").CurrentRegion.Borders.LineStyle = xlContinuous
.Range("a1").CurrentRegion.Offset(, 7).Resize(, 3).Borders.LineStyle = xlContinuous
For i = 5 To .Range("a1").CurrentRegion.Rows.Count Step 6
.Range("a" & i).Resize(3, 4).Font.Bold = True
.Range("a" & i).Offset(, 7).Resize(3, 3).Font.Bold = True
Next i
Application.Goto .Range("a1"), True
End With
Application.ScreenUpdating = True
End Sub