remplir des etiquettes

Sub test()
    Dim lbase As Integer, lig As Integer, lig2 As Integer, lig3 As Integer, meval As Variant, col As Integer
    lbase = 2
    Sheets(2).Range("C2:I" & Rows.Count).ClearContents
    Application.ScreenUpdating = False
    For lig = 2 To 815 Step 6
        lig3 = 2
        lig2 = 1
        lig4 = 3
        meval = Array("Valeur", "N° de Série", "SMI", "LA MUSIQUE")
        For col = 3 To 5
            With Cells(lig, col)
                .Value = meval(col - 3)
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
            End With
        Next
        For col = 7 To 9
            With Cells(lig, col)
                .Value = meval(col - 7)
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
            End With
        Next
        lig3 = lig3 + lig
        With Range(Cells(lig3, 3), Cells(lig3, 5))
            .Value = meval(3)
            .Merge
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter

        End With
        With Range(Cells(lig3, 7), Cells(lig3, 9))
            .Value = meval(3)
            .Merge
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter

        End With
        lig2 = lig2 + lig
        Range(Cells(lig2, 3), Cells(lig2, 5)).UnMerge
        Cells(lig2, 3).Value = Sheets(1).Cells(lbase, 7).Value
        Cells(lig2, 4).Value = Sheets(1).Cells(lbase, 2).Value
        Cells(lig2, 5).Value = Sheets(1).Cells(lbase, 1).Value
        lbase = lbase + 1
        Range(Cells(lig2, 7), Cells(lig2, 9)).UnMerge
        Cells(lig2, 7).Value = Sheets(1).Cells(lbase, 7).Value
        Cells(lig2, 8).Value = Sheets(1).Cells(lbase, 2).Value
        Cells(lig2, 9).Value = Sheets(1).Cells(lbase, 1).Value
        lbase = lbase - 1
        lig4 = lig4 + lig
        Range(Cells(lig4, 4), Cells(lig4, 5)).UnMerge
        Cells(lig4, 4).Value = Sheets(1).Cells(lbase, 17).Value
        Cells(lig4, 5).Value = Sheets(1).Cells(lbase, 18).Value
        lbase = lbase + 1
        Range(Cells(lig4, 8), Cells(lig4, 9)).UnMerge
        Cells(lig4, 8).Value = Sheets(1).Cells(lbase, 17).Value
        Cells(lig4, 9).Value = Sheets(1).Cells(lbase, 18).Value
        lbase = lbase + 1

    Next
     Application.ScreenUpdating = True
End Sub

Sub Etiquettes()
Dim t, c As Range, i&, j As Byte
t = Sheets("base").[A1].CurrentRegion.Resize(, 18)
Application.ScreenUpdating = False
Sheets("Etiquette").[C:I] = "" 'RAZ
Set c = Sheets("Etiquette").[C2] 'cellule de départ
For i = 2 To UBound(t)
  c = "VALEUR": c(, 2) = "N° de série": c(, 3) = "SMI"
  c(2) = t(i, 7): c(2, 2) = t(i, 2): c(2, 3) = t(i, 1)
  c(3) = "LA MUSIQUE": c(4, 2) = t(i, 17): c(4, 3) = t(i, 18)
  j = (i - 2) Mod 2
  Set c = c(IIf(j, 7, 1), IIf(j, -3, 5))
Next
End Sub