Macro copier/coller selon valeur d'une cellule

Bonjour à tous,

Je rencontre quelques difficultés à réaliser quelque chose qui me paraissait simple au départ

Pour chaque lignes (allant de la ligne 22 à 43) je souhaiterais copier la cellule de la colonne F correspondante et faire un copier coller dans un onglet "Etiquettes" fois la valeur de la cellule de la colonne Y correspondante (cette valeur est variable)

Par exemple en F22 j'ai "Lyon" et en Y22 j'ai 12 , je souhaiterai qu'il me copie 12 fois "Lyon" dans l'onglet "Etiquettes"

Malheureusement je ne suis tombé que sur ces deux codes sur internet que je n'arrive pas à adapter (peut-être pas adaptés ?)

Sub z_Copier_coller_xfois_une_ligne()

' la Feuil1 comporte les lignes à copier, et la colonne A le nombre de fois du copier coller

' la Feuil2 est la feuille de travail

Application.ScreenUpdating = False

Dim sh1 As Worksheet, sh2 As Worksheet

Dim lig As Long, cellule As Variant

Set sh1 = Worksheets("Feuil1")

Set sh2 = Worksheets("Feuil2")

For Each cellule In Range("A2:A65536")

If cellule.Value > 0 Then

For i = 1 To cellule.Value

lig = sh2.[A65536].End(xlUp).Row + 1

sh2.Rows(lig) = cellule.EntireRow.Value

Next i

End If

Next cellule

Application.ScreenUpdating = True

sh2.Select

MsgBox "Traitement fini"

End Sub

OU

Sub Test()

Dim I As Integer

For I = 3 To Range("F1").Value + 1

Range("B2:E2").Copy Range("B" & I)

Next I

End Sub

Merci beaucoup d'avance pour votre aide

Bonjour,

Une proposition à adapter

Sub ImpressionEtiquette()
Dim WsS As Worksheet, WsC As Worksheet
Dim Cel As Range
Dim LigneC As Long
    Set WsS = Worksheets("Saisie")
    Set WsC = Worksheets("Etiquettes")
    Application.ScreenUpdating = False
    WsC.Cells.ClearContents
    LigneC = 1
    For Each Cel In WsS.Range("F22:F43")
        If Cel.Offset(0, 19) > 0 Then
            For i = 1 To Cel.Offset(0, 19)
                WsC.Cells(LigneC, 1) = Cel
                LigneC = LigneC + 1
            Next i
        End If
    Next Cel
    WsC.PrintPreview
    Set WsC = Nothing: Set WsS = Nothing
End Sub

A+

C'est parfait !

C'est exactement ce qu'il me fallait, sans vouloir pousser le bouchon j'ai un petit soucis de mise en page sur mon onglet Etiquettes.

De manière à ce que la page ressorte bien sur une feuille A4 autocollante divisé en 5 , j'ai 5 lignes par pages avec comme lignes écrites la 1ère la 3ème et la 5ème, or quand je change

For I = 1 To Cel.Offset(0, 19)

WsC.Cells(LigneC, 1) = Cel

LigneC = LigneC + 1

Next I

en

For I = 1 To Cel.Offset(0, 19)

WsC.Cells(LigneC, 1) = Cel

LigneC = LigneC + 2

Next I

une page sur deux sera bonne car sur les pages paires le résultat sur porte sur les lignes 2 et 3, j'essaie de remettre en page manuellement à 3 lignes et de faire insérer une ligne mais ça va me décaler la mise en page et je devrai renouveler l'opération à chaque édition

Bonjour,

Si j'ai bien compris, tu dois obtenir 3 étiquettes par page avec une ligne de séparation entre chaque étiquette.

Sub ImpressionEtiquette()
Dim WsS As Worksheet, WsC As Worksheet
Dim Cel As Range
Dim LigneC As Long, Cptr As Long, j As Long
Dim i As Byte
    Set WsS = Worksheets("Saisie")
    Set WsC = Worksheets("Etiquettes")
    LigneC = 1
    i = 1
    Application.ScreenUpdating = False
    WsC.Cells.ClearContents
    For Each Cel In WsS.Range("F22:F43")
        If Cel.Offset(0, 19) > 0 Then
            Do While Cptr < Cel.Offset(0, 19)
                Cptr = Cptr + 1
                WsC.Cells(LigneC, 1) = Cel
                i = i + 2
                If i > 5 Then
                    i = 1
                    j = j + 5
                End If
                LigneC = i + j
            Loop
        End If
        Cptr = 0
    Next Cel
    WsC.PrintPreview
    Set WsC = Nothing: Set WsS = Nothing
End Sub

A+

C'est exactement ça

Merci de m'avoir consacré du temps, vous m'avez fait gagné des nombreuses heures sur ces tâches répétitives !!

J'essaie de joindre ce fabuleux code à celui là afin d'automatiser mes sauts de pages, ça marche cependant sauf pour la première page où figurent 4 lignes. Je me doute que c'est dû au

.Rows(1).Delete

Sub Sautdepage()

Sheets("Etiquettes").Select

Dim N As Long
Dim I As Integer

With ActiveSheet
    .ResetAllPageBreaks
    .Rows(1).Delete
N = .Range("A65536").End(xlUp).Row
    .PageSetup.PrintArea = "A1:A900" & N
End With

For I = 1 To N / 5
    ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=Cells(I * 5, 1)
Next I

End Sub

Essaie comme cela

Sub Sautdepage()
Dim N As Long
Dim I As Integer
    With Sheets("Etiquettes")
        .ResetAllPageBreaks
        N = .Range("A65536").End(xlUp).Row
        .PageSetup.PrintArea = "A1:A" & N
        For I = 1 To N / 5
            .HPageBreaks.Add Before:=Cells(I * 5 + 1, 1)
        Next I
    End With
End Sub

A+