XL 2016 créer et imprimer les étiquette autocollant

Seddiki_adz

XLDnaute Impliqué
Bonjour
j'ai besoin d'un code pour créer et imprimer les autocollant
Merci
 

Pièces jointes

  • 2525.xlsx
    13.1 KB · Affichages: 4

vgendron

XLDnaute Barbatruc
si tu changes la forme de tes étiquettes, forcément, le code n'est plus adapté
est ce que au moins tu essaies de comprendre ce que je te propose?

au passage.. j'espère juste que tu nes pas enseignant......sinon; c'est grave

VB:
Sub imprimer()

Dim TabData() As Variant
Dim NbEtiquette As Long
NbEtiquette = 4
With Sheets("Feuil1")
    fin = .Range("A" & .Rows.Count).End(xlUp).Row
    TabData = .Range("A2:F" & fin).Value
End With

With Sheets("Feuil3")
    .Activate
    indi = 1
    indj = 3
       For i = LBound(TabData, 1) To UBound(TabData, 1)
        .Cells(2 + (indi - 1) * 5, indj) = TabData(i, 1)
        .Cells(4 + (indi - 1) * 5, indj) = TabData(i, 3)
        .Cells(6 + (indi - 1) * 5, indj) = TabData(i, 4)
        .Cells(8 + (indi - 1) * 5, indj) = TabData(i, 5)
        .Cells(2 + (indi - 1) * 5, indj + 3) = TabData(i, 2)
        .Cells(8 + (indi - 1) * 5, indj + 3) = TabData(i, 6)
        
        indj = IIf(indj = 3, 9, 3)
        indi = IIf(indj = 3, indi + 1, indi)
        If ((i - 1) Mod NbEtiquette) + 1 = NbEtiquette Then
            indi = 1
            'lancer impression de la page
             ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
            clearlabel 'effacer les etiquettes
        End If
    Next i
End With

End Sub
Sub clearlabel()
With Sheets("Feuil3")
    .Range("C:C").ClearContents
    .Range("F:F").ClearContents
    .Range("I:I").ClearContents
    .Range("L:L").ClearContents
End With
End Sub
 

Discussions similaires

Réponses
4
Affichages
206
Réponses
11
Affichages
247

Statistiques des forums

Discussions
312 228
Messages
2 086 421
Membres
103 205
dernier inscrit
zch