Sub Copier()
Dim source, dest, w As Worksheet, i%, tablo, resu(), n&, j%, v, k&
source = Array("A3", "A11", "A19", "A27") 'à adapter
dest = Array("AQ3", "AU3", "AY3", "BC3") 'à adapter
For Each w In Worksheets
For i = 0 To UBound(source)
tablo = w.Range(source(i)).CurrentRegion.Resize(6) 'matrice, plus rapide
ReDim resu(1 To w.Rows.Count, 1 To 1)
n = 0
For j = 2 To UBound(tablo, 2)
v = tablo(2, j) 'valeur à recopier
For k = 1 To tablo(6, j)
n = n + 1
resu(n, 1) = v
Next k, j
With w.Range(dest(i))
If n Then .Resize(n) = resu 'restitution
.Offset(n).Resize(w.Rows.Count - n - .Row + 1).ClearContents 'RAZ en dessous
End With
Next i, w
End Sub