remplir des etiquettes

[gothc]

Bonjour le forum

je cherche de l'aide pour une macro pour remplir des étiquettes a partir d'une base

merci de votre aide

 

[gothc]

Re : remplir des etiquettes

je regarde sur le forum mais je trouve pas de sujet identique

 

[Dugenou]

Re : remplir des etiquettes

Bonjour,
tu veux absolument une macro ?
parce que c'est faisable par formule...

 

[gothc]

Re : remplir des etiquettes

Bonjour Dugenou Oui je préfére une Macro s'est le plus simple je pense vu le nombre étiquette
Merci pour votre message Bonne journée

 

[Dugenou]

Re : remplir des etiquettes

une dernière tentative : connais-tu le publipostage sous word qui te permet d'éditer des étiquettes à partir d'un fichier excel en quelques clics ?

 

[gothc]

Re : remplir des etiquettes

non je connais pas le publipostage sous word une super idée a mon probleme
Merci pour ton aide Dugenou

 

[gothc]

Re : remplir des etiquettes

sauf que mes etiquettes sont tres petite donc difficile pour une impression une a une
peut on generer une feuille impression avec plusieurs étiquette a partir d'un publipostage sous word l'usine a gaz je pense😎😎😎

 

[Dugenou]

Re : remplir des etiquettes

non, aucun probleme
dans word tu dois choisir ton type d'étiquette (idéalement il existe déjà : genre avery 3547 etc...) sinon tu peux fabriquer ton propre modèle d'étiquette en spécifiant le nb par ligne, par colonne et le pas horizontal et vertical.
Ensuite avec publipostage/étiquettes tu edite des feuilles entières dont chaque étiquette correspond à une ligne de ton classeur excel.
Pour ma part je génère des étiquettes mailing pour 500 destinataires en quelques clics à l'aide d'un modèle pré enregistré

 

[gothc]

Re : remplir des etiquettes

ok Merci a vous je vais faire un test
bonne journée

 

[gilbert_RGI]

Re : remplir des etiquettes

bonjour,

voilà une macro

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

 

[gothc]

Re : remplir des etiquettes

Bonjour gilbert_RGI

un grand Merci a toi la macro fonctionne super bien
je regarde pour comprendre ton code
encore Merci Bonne journée
amitié sincère Christophe

 

[gilbert_RGI]

Re : remplir des etiquettes

j'ai rectifié car il y avait des cellules fusionnées qui n'auraient pas du être

 

[job75]

Re : remplir des etiquettes

Bonjour à tous,

A priori les étiquettes sont formatées en nombre suffisant.

Sinon les compléter par copier/coller.

Pour les remplir avec les valeurs, sur le fichier du post #1 :

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

A+

 

[Staple1600]

Re : remplir des etiquettes

Bonsoir à tous

Je voudrais pas laisser tout seul Dugenou 😉
Donc je plussoie à sa proposition : publipostage avec Word.
https://www.excel-downloads.com/threads/remplir-des-etiquettes.231110/

 

[job75]

Re : remplir des etiquettes

Bonjour à tous,

Une solution plus complète avec impression des étiquettes dans ce fichier.

Edit 1 : modifié pour que la Dernière cellule soit en I7 afin d'accélérer la copie.

Edit 2 : modifié pour traiter les cas où il y a moins de 3 étiquettes.

A+