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
sousou à dit:
Tes exemples sont pas facile à comprendre en fonction de tes données dans le fichier?
Cliquez pour agrandir...
ok j'ai mis dans l'exemple les vraies informations figurant dans la feuille 1960 lignes 1et 2 pour le couple et ligne 32 pour la femelle

les dimensions de la feuille étiquettes 16 étiquettes/feuille format étiquette 105 x 37 mm
 

Pièces jointes

Vote positif 0 Vote négatif
AIGOIN à dit:
ok j'ai mis dans l'exemple les vraies informations figurant dans la feuille 1960 lignes 1et 2 pour le couple et ligne 32 pour la femelle

les dimensions de la feuille étiquettes 16 étiquettes/feuille format étiquette 105 x 37 mm
Cliquez pour agrandir...
J'ai mis les étiquettes sur deux feuilles feuille couple et feuille male et femelle
Merci pour votre aide
 

Pièces jointes

Vote positif 0 Vote négatif
Bonjour AIGOIN, le forum,

Voyez le fichier joint et le code de la feuille "Créations" :
Code: 
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.ResetAllPageBreaks
n = 0: X = 0: Y = 0
If Target = "Toutes" Then
    For Each w In Worksheets
        If IsNumeric(w.Name) Then
            Etiquettes w.Name
        End If
    Next w
ElseIf Target <> "" Then
    Etiquettes CStr(Target)
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")
Application.ScreenUpdating = False
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
        s1.Copy
        F.Paste
        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
        If n Mod 16 = 0 Then F.HPageBreaks.Add F.Shapes(n).BottomRightCell.EntireRow 'sauts de pages
        MAJ T, i
    Else
        For j = i To i + 1
            n = n + 1
            s2.Copy
            F.Paste
            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
            If n Mod 16 = 0 Then F.HPageBreaks.Add F.Shapes(n).BottomRightCell.EntireRow 'sauts de pages
            MAJ T, j
        Next j
    End If
Next i
Application.Goto F.[A1], True 'cadrage
End Sub

Sub MAJ(T, i&)
Dim txt$
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
F.Shapes(n).TextFrame.Characters.Text = txt
End Sub
Il s'exécute quand on choisi une feuille ou "Toutes" dans la liste de validation en J3.

Dans la feuille "Etiquettes" la hauteur de toutes les lignes est 1.

Pour l'impression, les sauts de pages créés limitent le nombre d'étiquettes à 16 par page.

A+
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
job75 à dit:
Bonjour AIGOIN, le forum,

Voyez le fichier joint et le code de la feuille "Créations" :
Code: 
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.ResetAllPageBreaks
n = 0: X = 0: Y = 0
If Target = "Toutes" Then
    For Each w In Worksheets
        If IsNumeric(w.Name) Then
            Etiquettes w.Name
        End If
    Next w
ElseIf Target <> "" Then
    Etiquettes CStr(Target)
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")
Application.ScreenUpdating = False
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
        s1.Copy
        F.Paste
        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
        If n Mod 16 = 0 Then F.HPageBreaks.Add F.Shapes(n).BottomRightCell.EntireRow 'sauts de pages
        MAJ T, i
    Else
        For j = i To i + 1
            n = n + 1
            s2.Copy
            F.Paste
            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
            If n Mod 16 = 0 Then F.HPageBreaks.Add F.Shapes(n).BottomRightCell.EntireRow 'sauts de pages
            MAJ T, j
        Next j
    End If
Next i
Application.Goto F.[A1], True 'cadrage
End Sub

Sub MAJ(T, i&)
Dim txt$
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
F.Shapes(n).TextFrame.Characters.Text = txt
End Sub
Il s'exécute quand on choisi une feuille ou "Toutes" dans la liste de validation en J3.

Dans la feuille "Etiquettes" la hauteur de toutes les lignes est 1.

Pour l'impression, les sauts de pages créés limitent le nombre d'étiquettes à 16 par page.

A+
Cliquez pour agrandir...
Merci c'est super pour les feuilles individuelles, j'ai ai rajouté une à la liste déroulante ça fonctionne très bien.
La macro plante pour toutes : la méthode "copy"de l'obet 'shape' a échoué F.Paste
Super travail chapeau bas
 
Vote positif 0 Vote négatif
AIGOIN à dit:
La macro plante pour toutes : la méthode "copy"de l'obet 'shape' a échoué F.Paste
Cliquez pour agrandir...
Pour forcer la copie j'ai ajouté 2 boucles Do/Loop, dites-moi si ça va mieux :
VB: 
        Do
            On Error Resume Next
            s1.Copy
            F.Paste
        Loop While Err
Par ailleurs j'ai ajouté le formatage "gras" dans la macro MAJ :
VB: 
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
 

Pièces jointes

Vote positif 0 Vote négatif
job75 à dit:
Pour forcer la copie j'ai ajouté 2 boucles Do/Loop, dites-moi si ça va mieux :
VB: 
        Do
            On Error Resume Next
            s1.Copy
            F.Paste
        Loop While Err
Par ailleurs j'ai ajouté le formatage "gras" dans la macro MAJ :
VB: 
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
Cliquez pour agrandir...
ça fonctionne très bien pour les étiquettes, par contre impossible d'imprimer au format 16 étiquettes de 105 mm x 37 mm
Merci de voir si une mise en page pour ces formats est possible ?
De plus, vous serait-il possible de mettre la liste déroulante sur un petit userform sur lequel je mettrai un bouton pour imprimer
Merci de voir si cela est possible.
Alain
 
Vote positif 0 Vote négatif
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
 

Pièces jointes

Vote positif 0 Vote négatif
Bonjour le forum,
AIGOIN à dit:
ça fonctionne très bien pour les étiquettes, par contre impossible d'imprimer au format 16 étiquettes de 105 mm x 37 mm
Cliquez pour agrandir...
Chez moi les sauts de pages créés permettent de limiter l'impression de la feuille "Etiquettes" à 16 étiquettes par page.

Menu Fichier => Imprimer.

Je ne vois pas du tout ce que vous voulez de plus.

Quant à l'UserForm il ne servirait à rien, la liste de validation suffit.

A+
 
Vote positif 0 Vote négatif
job75 à dit:
Bonjour le forum,

Chez moi les sauts de pages créés permettent de limiter l'impression de la feuille "Etiquettes" à 16 étiquettes par page.

Menu Fichier => Imprimer.

Je ne vois pas du tout ce que vous voulez de plus.

Quant à l'UserForm il ne servirait à rien, la liste de validation suffit.

A+
Cliquez pour agrandir...
Bonjour,
Toujours les mêmes problèmes d'impression, il y a bien 16 étiquettes mais avec des marges énormes en haut, en bas et sur les côtés. Quand je modifie il manque deux étiquettes en bas. En réalité, tout fonctionne super mais je ne peux pas utiliser le super travail à cause de l'impression.
Autre problème, si la feuille ne comprends pas 16 étiquettes, les étiquettes créées se retrouvent au milieu de la feuille, je pense qu'il faudrait créer X étiquettes vides pour arriver à 16.
Concernant l'userform je demandais car je suis plus habitué à utiliser des combobox mais la liste de validation va bien aussi.
Voyez si vous pouvez faire quelque chose pour l'impression, la je suis démuni, merci encore pour le travail
PS: j'ai une petite imprimante Epson 235.
 
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
149
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
156
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
878
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