XL 2021 création d'étiquettes

[AIGOIN]

Bonjour,
En pièce jointe, une demande de création d'étiquettes.

Merci pour votre aide

Alain

 

[AIGOIN]

Bonjour AIGOIN, le forum,

Le code fait pourtant la même chose qu'au post #38 mais en effet j'ai ajouté dans la Worksheet_Change :

F.Columns.ColumnWidth = 0.1

Essayez en ôtant cette instruction.

A+

C'était bien ça merci beaucoup pour le travail accompli
Bonne journée

 

[AIGOIN]

C'était bien ça merci beaucoup pour le travail accompli
Bonne journée

Une dernière demande si cela est possible, copier avec une macro toutes les feuilles_expo numériques (1110, 1127, etc.) avec souche éleveur dans fichier étiquettes_expo, j'ai essayé mais en vain (bouton sur la feuille étiquette)
Merci
Alain

 

[job75]

La macro affectée au bouton :

Sub RapatrierFeuilles()
Dim fichier As Variant, w As Worksheet
Do
    fichier = Application.GetOpenFilename("Fichiers Excel (*.xls*),*.xls*")
Loop While Mid(fichier, InStrRev(fichier, "\") + 1) = ThisWorkbook.Name
If fichier = False Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'---suppression des feuilles existantes---
For Each w In Worksheets
    If IsNumeric(w.Name) Then w.Delete
Next w
'---copie les feuilles du fichier choisi---
With Workbooks.Open(fichier) 'ouverture du fichier
    For Each w In .Worksheets
        If IsNumeric(w.Name) Then w.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    Next w
    .Close False 'fermeture
End With
Sheets("Créations").Activate
End Sub

 

[AIGOIN]

La macro affectée au bouton :

Sub RapatrierFeuilles()
Dim fichier As Variant, w As Worksheet
Do
    fichier = Application.GetOpenFilename("Fichiers Excel (*.xls*),*.xls*")
Loop While Mid(fichier, InStrRev(fichier, "\") + 1) = ThisWorkbook.Name
If fichier = False Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'---suppression des feuilles existantes---
For Each w In Worksheets
    If IsNumeric(w.Name) Then w.Delete
Next w
'---copie les feuilles du fichier choisi---
With Workbooks.Open(fichier) 'ouverture du fichier
    For Each w In .Worksheets
        If IsNumeric(w.Name) Then w.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    Next w
    .Close False 'fermeture
End With
Sheets("Créations").Activate
End Sub

Merci beaucoup, c'est super
Bonne soirée