Duplication de cellules excel

Sub copier4saut5()
Dim code()
nl = Cells(Rows.Count, 1).End(xlUp).Row
nc = Cells(2, Columns.Count).End(xlToLeft).Column
c = 0
Set shr = Sheets("Résultat")
ReDim code(1)
For co = 2 To nc
    For li = 3 To nl
        If Len(Cells(li, co)) > 3 Then
        code(c) = Cells(li, co).Value
        c = c + 1
        ReDim Preserve code(0 To c)
        End If
    Next li
Next co
' renseigner feuille résultat
lir = 1
shr.Columns(7).ClearContents
For r = 0 To (c - 1)
    For st = 0 To 3
        shr.Cells(lir + (6 * st), 7) = code(r)
    Next st
    lir = lir + (6 * st)
Next r
MsgBox "Les " & c - 1 & " codes sont reportées"
End Sub