XL 2021 création d'étiquettes

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion AIGOIN
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
Trier par date Trier par votes
Bonjour,

AIGOIN à dit:
J'ai oublié de vous donner les dimensions de la feuille étiquettes 16 étiquettes/feuille format étiquette 105 x 37 mm
Cliquez pour agrandir...
Si tu n'imprimes pas sur du papier photo, j'ai bien peur que ce que tu demandes là soit impossible.
(et même avec du papier photo, pas sûr que ça passe car il faut voir si tu peux imprimer du texte)

Deux de tes étiquettes côte à côte font 105+105 = 210 mm et une feuille A4 fait... 210 mm, donc ça passe pas. Il faut très légèrement diminuer la largeur de tes étiquettes (102 mm devraient théoriquement passer, mais par sécurité je descendrais à 101 voire 100 mm).
 
Dernière édition:
Vote positif 0 Vote négatif
Rheeem à dit:
Il est impossible d’imprimer les 16 étiquettes sur un papier avec les dimensions traditionnelles A4
un simple calcul 210 x 270 = 56700 et 105 x 37 *16 = 62160
Il faudrait diminuer un peu la taille 87 x 34 comme dans l’exemple
Cliquez pour agrandir...
J'avais fait exactement le même calcul, mais avec les vraies valeurs, et en superficies théoriques ça passe sur papier photo car 62160 <= 62370. 😉
 
Vote positif 0 Vote négatif
sousou à dit:
Bonjour
J'avais laissé la main à Job 75,( bien meilleur)😉
Mais comme j'avais fait un truc!....
J' utilise des modèle ( feuil3 qui te permette de formater à loisir
la feuille Fimp est à règler(mise en page) en fonction de ton imprimante et des feuilles étiquettes choisies
Cliquez pour agrandir...
Bonjour,
ça fonctionne très bien j'ai réussi à l'adapter à l'imprimante. Les deux boutons sont inactifs pour l'instant, avez vous l'intention d'y mettre une macro pour étiquette un éleveur et tous les éleveurs?
Je pense que c'est la solution la plus rapide de toutes les contributions
Merci et à bientôt
 
Vote positif 0 Vote négatif
Bonjour le forum,
AIGOIN à dit:
Autre problème, si la feuille ne comprends pas 16 étiquettes, les étiquettes créées se retrouvent au milieu de la feuille
Cliquez pour agrandir...
Bien sûr puisque j'ai centré les pages horizontalement et verticalement à l'impression (menu Mise en page => Marges).

Il suffit de décocher la case Verticalement pour imprimer en haut.

En effet à cause des marges les étiquettes auront des dimensions inférieures à 105 x 37 mm.

A+
 
Vote positif 0 Vote négatif
Avec cette solution on imprime les pages une par une et à chaque fois on supprime les étiquettes.

Cela permet d'avoir toutes les marges égales à zéro et d'imprimer sur une page :
VB: 
Option Compare Text 'la casse est ignorée
Dim F As Worksheet, n&, X!, Y! 'mémorise les variables

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$J$3" Then Exit Sub
Dim w As Worksheet
Set F = Sheets("Etiquettes")
F.DrawingObjects.Delete 'RAZ
F.PageSetup.FitToPagesWide = 1
F.PageSetup.FitToPagesTall = 1
Application.ScreenUpdating = False
If Target = "Toutes" Then
    For Each w In Worksheets
        If IsNumeric(w.Name) Then Etiquettes w.Name
    Next w
ElseIf Target <> "" Then
    Etiquettes CStr(Target)
End If
If F.DrawingObjects.Count Then
    'F.PrintOut ' pour imprimer
    F.PrintPreview 'pour voir l'aperçu
    F.DrawingObjects.Delete
    n = 0: X = 0: Y = 0
End If
End Sub

Sub Etiquettes(souche$)
Dim s1 As Shape, s2 As Shape, T, i&, j&
Set s1 = Shapes("ZT_1"): Set s2 = Shapes("ZT_2")
Set T = Sheets(souche).ListObjects(1).Range
For i = 2 To T.Rows.Count Step 2
    If T(i, 7) = "couple" Then
        n = n + 1
        Do
            On Error Resume Next
            s1.Copy
            F.Paste
        Loop While Err
        F.Shapes(n).Left = X
        F.Shapes(n).Top = Y
        If n Mod 2 Then
            X = F.Shapes(n).Width
        Else
            X = 0
            Y = Y + F.Shapes(n).Height
        End If
        MAJ T, i
        If n Mod 16 = 0 Then
            'F.PrintOut ' pour imprimer
            F.PrintPreview 'pour voir l'aperçu
            F.DrawingObjects.Delete
            n = 0: X = 0: Y = 0
        End If
    Else
        For j = i To i + 1
            n = n + 1
            Do
                On Error Resume Next
                s2.Copy
                F.Paste
            Loop While Err
            F.Shapes(n).Left = X
            F.Shapes(n).Top = Y
            If n Mod 2 Then
                X = F.Shapes(n).Width
            Else
                X = 0
                Y = Y + F.Shapes(n).Height
            End If
            MAJ T, j
            If n Mod 16 = 0 Then
                'F.PrintOut 'pour voir l'aperçu
                F.PrintPreview 'aperçu
                F.DrawingObjects.Delete
                n = 0: X = 0: Y = 0
            End If
        Next j
    End If
Next i
End Sub

Sub MAJ(T, i&)
Dim txt$, p%
txt = F.Shapes(n).TextFrame.Characters.Text
txt = Replace(txt, "NOM PRENOM", T(-3, 3))
txt = Replace(txt, "1960", T(0, 3))
If T(i, 7) = "couple" Then
    txt = Replace(txt, "01 et 02", Format(T(i, 1), "00") & " et " & Format(T(i + 1, 1), "00"))
    txt = Replace(txt, "2025", T(i, 5))
    txt = Replace(txt, "2024", T(i + 1, 5))
    txt = Replace(txt, "011", Format(T(i, 4), "000"))
    txt = Replace(txt, "015", Format(T(i + 1, 4), "000"))
    txt = Replace(txt, "Perruche 1", T(i, 3))
    txt = Replace(txt, "Perruche 2", T(i + 1, 3))
    txt = Replace(txt, "40 E", T(i + 1, 7) & " E")
Else
    txt = Replace(txt, "32a", Format(T(i, 1), "00"))
    txt = Replace(txt, "2024", T(i, 5))
    txt = Replace(txt, "040", Format(T(i, 4), "000"))
    If T(i, 6) = "M" Then txt = Replace(txt, "FEMELLE", "MALE") Else txt = Replace(txt, "Femelle", "FEMELLE")
    txt = Replace(txt, "Perruche", T(i, 3))
    txt = Replace(txt, "40 E", T(i, 7) & " E")
End If
With F.Shapes(n).TextFrame
    .Characters.Text = txt
    p = InStr(txt, vbLf & "M ")
    If p Then .Characters(p + 1, 1).Font.Bold = True
    p = InStr(txt, "F ")
    If p Then .Characters(p, 1).Font.Bold = True
    p = InStr(txt, "VENTE")
    If p Then .Characters(p).Font.Bold = True
    p = InStr(txt, "Prix")
    If p Then .Characters(p).Font.Bold = True
End With
End Sub
 

Pièces jointes

Vote positif 0 Vote négatif
AIGOIN à dit:
Bonjour,
ça fonctionne très bien j'ai réussi à l'adapter à l'imprimante. Les deux boutons sont inactifs pour l'instant, avez vous l'intention d'y mettre une macro pour étiquette un éleveur et tous les éleveurs?
Je pense que c'est la solution la plus rapide de toutes les contributions
Merci et à bientôt
Cliquez pour agrandir...
comment ça les deux boutons? J'ai utilisé imprime une feuille et imprime toutes les feuilles
Tu veux autres chose?
 
Vote positif 0 Vote négatif
job75 à dit:
Avec cette solution on imprime les pages une par une et à chaque fois on supprime les étiquettes.

Cela permet d'avoir toutes les marges égales à zéro et d'imprimer sur une page :
VB: 
Option Compare Text 'la casse est ignorée
Dim F As Worksheet, n&, X!, Y! 'mémorise les variables

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address <> "$J$3" Then Exit Sub
Dim w As Worksheet
Set F = Sheets("Etiquettes")
F.DrawingObjects.Delete 'RAZ
F.PageSetup.FitToPagesWide = 1
F.PageSetup.FitToPagesTall = 1
Application.ScreenUpdating = False
If Target = "Toutes" Then
    For Each w In Worksheets
        If IsNumeric(w.Name) Then Etiquettes w.Name
    Next w
ElseIf Target <> "" Then
    Etiquettes CStr(Target)
End If
If F.DrawingObjects.Count Then
    'F.PrintOut ' pour imprimer
    F.PrintPreview 'pour voir l'aperçu
    F.DrawingObjects.Delete
    n = 0: X = 0: Y = 0
End If
End Sub

Sub Etiquettes(souche$)
Dim s1 As Shape, s2 As Shape, T, i&, j&
Set s1 = Shapes("ZT_1"): Set s2 = Shapes("ZT_2")
Set T = Sheets(souche).ListObjects(1).Range
For i = 2 To T.Rows.Count Step 2
    If T(i, 7) = "couple" Then
        n = n + 1
        Do
            On Error Resume Next
            s1.Copy
            F.Paste
        Loop While Err
        F.Shapes(n).Left = X
        F.Shapes(n).Top = Y
        If n Mod 2 Then
            X = F.Shapes(n).Width
        Else
            X = 0
            Y = Y + F.Shapes(n).Height
        End If
        MAJ T, i
        If n Mod 16 = 0 Then
            'F.PrintOut ' pour imprimer
            F.PrintPreview 'pour voir l'aperçu
            F.DrawingObjects.Delete
            n = 0: X = 0: Y = 0
        End If
    Else
        For j = i To i + 1
            n = n + 1
            Do
                On Error Resume Next
                s2.Copy
                F.Paste
            Loop While Err
            F.Shapes(n).Left = X
            F.Shapes(n).Top = Y
            If n Mod 2 Then
                X = F.Shapes(n).Width
            Else
                X = 0
                Y = Y + F.Shapes(n).Height
            End If
            MAJ T, j
            If n Mod 16 = 0 Then
                'F.PrintOut 'pour voir l'aperçu
                F.PrintPreview 'aperçu
                F.DrawingObjects.Delete
                n = 0: X = 0: Y = 0
            End If
        Next j
    End If
Next i
End Sub

Sub MAJ(T, i&)
Dim txt$, p%
txt = F.Shapes(n).TextFrame.Characters.Text
txt = Replace(txt, "NOM PRENOM", T(-3, 3))
txt = Replace(txt, "1960", T(0, 3))
If T(i, 7) = "couple" Then
    txt = Replace(txt, "01 et 02", Format(T(i, 1), "00") & " et " & Format(T(i + 1, 1), "00"))
    txt = Replace(txt, "2025", T(i, 5))
    txt = Replace(txt, "2024", T(i + 1, 5))
    txt = Replace(txt, "011", Format(T(i, 4), "000"))
    txt = Replace(txt, "015", Format(T(i + 1, 4), "000"))
    txt = Replace(txt, "Perruche 1", T(i, 3))
    txt = Replace(txt, "Perruche 2", T(i + 1, 3))
    txt = Replace(txt, "40 E", T(i + 1, 7) & " E")
Else
    txt = Replace(txt, "32a", Format(T(i, 1), "00"))
    txt = Replace(txt, "2024", T(i, 5))
    txt = Replace(txt, "040", Format(T(i, 4), "000"))
    If T(i, 6) = "M" Then txt = Replace(txt, "FEMELLE", "MALE") Else txt = Replace(txt, "Femelle", "FEMELLE")
    txt = Replace(txt, "Perruche", T(i, 3))
    txt = Replace(txt, "40 E", T(i, 7) & " E")
End If
With F.Shapes(n).TextFrame
    .Characters.Text = txt
    p = InStr(txt, vbLf & "M ")
    If p Then .Characters(p + 1, 1).Font.Bold = True
    p = InStr(txt, "F ")
    If p Then .Characters(p, 1).Font.Bold = True
    p = InStr(txt, "VENTE")
    If p Then .Characters(p).Font.Bold = True
    p = InStr(txt, "Prix")
    If p Then .Characters(p).Font.Bold = True
End With
End Sub
Cliquez pour agrandir...
 
Vote positif 0 Vote négatif
AIGOIN à dit:
je te renvois ma version modifié regarde à partir de la 5ème étiquette ça décale et il y a une grosse marge en bas de page j'en peux plus !!!!!
Cliquez pour agrandir...
C'est normal car la largeur 10,5 cm des Shapes est trop grande, Excel applique un zoom < 100 pour ajuster à une page en largeur.

Dans le fichier joint j'ai donné aux Shapes la taille 10,5 x 4 cm, l'impression les affiche à 10,1 x 3,5 cm chez moi.
 

Pièces jointes

Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

A
  • Question Question
XL 2021 code postal dans combobox
Réponses
11
Affichages
156
AIGOIN
A
A
  • Résolu(e)
XL 2013 Création étiquette et nombre indiqué en colonne
Réponses
9
Affichages
766
acuponctus
A
V
  • Question Question
XL 2019 Fonction si
Réponses
7
Affichages
395
vipi61
V
W
  • Question Question
Microsoft 365 Aide sur petites formules et graphique..
Réponses
4
Affichages
148
WEIDER
W
C
  • Résolu(e)
XL 2016 rapatrier des données d'un onglet vers une feuille récapitulatrice via un menu déroulant
Réponses
4
Affichages
159
cocotte38
C
G
  • Question Question
Microsoft 365 Colorer un graphique x-y scatter
Réponses
9
Affichages
87
bsalv
B
R
  • Question Question
XL 2021 Un planning/calendrier d'ouverture des points de ventes
Réponses
2
Affichages
345
Rocket
R
B
  • Question Question
Microsoft 365 Protection de zone de cellule selon utilisateur sur un fichier Excel
Réponses
2
Affichages
154
berta8683
B
M
  • Question Question
Microsoft 365 Masque de saisie Décaissement
Réponses
12
Affichages
413
Piment
P
S
  • Question Question
XL 2021 Lien mail hypertexte fonctionnel
Réponses
4
Affichages
220
sfconstant
S
D
  • Résolu(e)
XL 2016 Zone d'impression et mise en page
Réponses
4
Affichages
132
Phil69970
Phil69970
G
  • Question Question
Microsoft 365 insertion d'une ou plusieurs pièces jointe dans un mail via VBA
Réponses
6
Affichages
349
GG Delcroix
G
O
  • Question Question
XL 2016 Erreur d'exécution 32809 Erreur définie par l'application ou par l'objet
Réponses
0
Affichages
424
Oddoneju
O
S
  • Question Question
Autres destination Combobox1
Réponses
4
Affichages
388
stefezj
S
natorp
  • Résolu(e)
XL 2019 Rechercher en fonction d'une date
Réponses
7
Affichages
120
natorp
natorp
A
  • Question Question
XL 2021 Fichier Excel VBA mis en quarantaine par l'antivirus
2
Réponses
19
Affichages
876
fanch55
fanch55
Phoenix23
  • Résolu(e)
XL 2021 Tableau Classement Skull King
Réponses
6
Affichages
286
Cousinhub
Cousinhub
A
  • Résolu(e)
XL 2019 Optimisation code VBA (Icônes flottantes)
Réponses
14
Affichages
467
Amilo
A
K
  • Question Question
XL 2016 Création base donnée gestion assurance sociale des agents
Réponses
3
Affichages
314
krimodz2008
K
E
  • Question Question
XL 2013 classement du ligue de football
Réponses
4
Affichages
224
Noham
Noham
Retour