Remplissage a la suite

Le 25/09/2020 à 13:33

Bonjour à tous

J'ai un tableau avec de cellules répertoriée par catégorie.

J'aimerais en sortir une liste pour faire des étiquettes.

J'ai commencé le code, mais cela ne va pas.. je dois mélanger certaines fonctions.

Explication:

J'ai 2 feuilles -1 Etiquettes à imprimer

2 Importation

Dans la feuille importation se trouvent les référence classée par catégorie

Dans la feuille Etiquettes a imprimer, j'aimerais que les étiquettes commence a la ligne 1 sur 6 colonnes jusqu'au bout,

Dans mon classeur j'ai fait manuellement ce que je souhaite dans la page Etiquettes à imprimer.

J'espère que c'est assez clair.

Merci d'avance

20etiquettes.xlsm (108.66 Ko)
Le 25/09/2020 à 15:48

Bonjour Damsa17, le forum,

Un essai.....le traitement est un peu long..8 secondes sur ma bécane

Sub test()
 Dim plage As Range, cel As Range
 Dim derlig As Integer, dercol As Integer
 Dim dernierecolonne As Integer, derniereligne As Integer, colonne As Integer

 derlig = 1  '..................................................................définit la ligne sur laquelle il faut écrire(Feuille "Etiquettes à imprimer")
 dercol = 1  '..................................................................définit la colonne sur laquelle il faut écrire(Feuille "Etiquettes à imprimer")

 Application.ScreenUpdating = False

 With Sheets("Importation") '...................................................agit sur la feuille "Importation"
  dernierecolonne = .Cells(1, Cells.Columns.Count).End(xlToLeft).Column '.......dernière colonne utilisée (feuille "Importation")
  colonne = 1 '.................................................................colonne de départ (feuille "Importation")
    While colonne <= dernierecolonne '..........................................boucle sur les colonnes jusqu'à la dernière (feuille "Importation")
     derniereligne = .Cells(Rows.Count, colonne).End(xlUp).Row '................dernière ligne utilisée de la colonne (feuille "Importation")
      Set plage = Range(.Cells(1, colonne), .Cells(derniereligne, colonne)) '...définit la plage (feuille "Importation")
      For Each cel In plage '...................................................boucle sur chaque cellule de la plage (feuille "Importation")
       If cel.Value <> "" Then '................................................si la cellule n'est pas vide
        If dercol = 7 Then dercol = 1: derlig = derlig + 1 '....................dès qu'on atteint la septième colonne, on passe sur la ligne suivante (Feuille "Etiquettes à imprimer")
         cel.Copy Sheets("Etiquettes à imprimer").Cells(derlig, dercol) '.......on copie la valeur sur la feuille Etiquettes à imprimer
         dercol = dercol + 1 '..................................................incrémente dercol de 1 pour écrire à côté de la valeur précédente
        End If '................................................................fin de la condition
      Next cel '................................................................passe à la cellule suivante
   colonne = colonne + 1 '......................................................passe à la colonne suivante
   Wend
 End With
End Sub

CTRL + e pour exécuter la macro....

6etiquettes-damsa17.xlsm (110.20 Ko)

Nul doute qu'un pro devrait te proposer un code plus performant,

Cordialement,

Le 25/09/2020 à 16:08

Bonjour

J'ai un code sous le coude mais la mise en forme (Gras uniquement sur les chiffres) ne sera pas identique à celle montrée dans la feuille Importation. Intérêt ou pas ?

Cordialement

Le 25/09/2020 à 16:17
xorsankukai a écrit :

Un essai.....le traitement est un peu long..8 secondes sur ma bécane

Merci, ca fonctionne nickel.

C'est vrai que c'est un peu long, mais bon je ne suis pas pressé ;-)

Le 25/09/2020 à 16:18
Dan a écrit :

Bonjour

J'ai un code sous le coude mais la mise en forme (Gras uniquement sur les chiffres) ne sera pas identique à celle montrée dans la feuille Importation. Intérêt ou pas ?

Cordialement

Oui a la limite la mise en forme pourra se faire après ;-)

Le 25/09/2020 à 16:43

Re

Essayez comme ceci mais le souci de la mise en forme est du à votre retour à la ligne dans chaque cellule. Une solution serait de mettre tout en gras.

Sub Impression_etiquettes()
Dim LCO As Integer, i As Integer, j As Integer, lig As Integer
Dim tablo()

Application.ScreenUpdating = False

On Error Resume Next
Sheets("Etiquettes à imprimer").Cells.Delete
On Error GoTo 0

LCO = Sheets("Importation").Cells(1, Sheets("Importation").Columns.Count).End(xlToLeft).Column

For j = 1 To LCO
    LCE = Sheets("Importation").Cells(Sheets("Importation").Rows.Count, j).End(xlUp).Row

    ReDim tablo(1 To LCE)
    On Error Resume Next

    For i = 1 To LCE Step 6

        tablo(1) = Sheets("Importation").Cells(i, j)
        tablo(2) = Sheets("Importation").Cells(i + 1, j)
        tablo(3) = Sheets("Importation").Cells(i + 2, j)
        tablo(4) = Sheets("Importation").Cells(i + 3, j)
        tablo(5) = Sheets("Importation").Cells(i + 4, j)
        tablo(6) = Sheets("Importation").Cells(i + 5, j)

    With Sheets("Etiquettes à imprimer")
        lig = .Range("A" & .Rows.Count).End(xlUp).Row + 1
        .Range("A" & lig & ":F" & lig) = tablo
    End With

    Next i

Next j
With Sheets("Etiquettes à imprimer").Cells
    .EntireRow.AutoFit
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Replace What:="#N/A", Replacement:=""
End With
End Sub

Au fait ce fil ci est toujours d'actualité ?? car il n'est pas cloturé --> https://forum.excel-pratique.com/excel/tri-de-cellules-146455

Cordialement

Le 25/09/2020 à 19:05
Dan a écrit :

Re

Essayez comme ceci mais le souci de la mise en forme est du à votre retour à la ligne dans chaque cellule. Une solution serait de mettre tout en gras.

Sub Impression_etiquettes()
Dim LCO As Integer, i As Integer, j As Integer, lig As Integer
Dim tablo()

Application.ScreenUpdating = False

On Error Resume Next
Sheets("Etiquettes à imprimer").Cells.Delete
On Error GoTo 0

LCO = Sheets("Importation").Cells(1, Sheets("Importation").Columns.Count).End(xlToLeft).Column

For j = 1 To LCO
    LCE = Sheets("Importation").Cells(Sheets("Importation").Rows.Count, j).End(xlUp).Row

    ReDim tablo(1 To LCE)
    On Error Resume Next

    For i = 1 To LCE Step 6

        tablo(1) = Sheets("Importation").Cells(i, j)
        tablo(2) = Sheets("Importation").Cells(i + 1, j)
        tablo(3) = Sheets("Importation").Cells(i + 2, j)
        tablo(4) = Sheets("Importation").Cells(i + 3, j)
        tablo(5) = Sheets("Importation").Cells(i + 4, j)
        tablo(6) = Sheets("Importation").Cells(i + 5, j)

    With Sheets("Etiquettes à imprimer")
        lig = .Range("A" & .Rows.Count).End(xlUp).Row + 1
        .Range("A" & lig & ":F" & lig) = tablo
    End With

    Next i

Next j
With Sheets("Etiquettes à imprimer").Cells
    .EntireRow.AutoFit
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Replace What:="#N/A", Replacement:=""
End With
End Sub

Au fait ce fil ci est toujours d'actualité ?? car il n'est pas cloturé --> https://forum.excel-pratique.com/excel/tri-de-cellules-146455

Cordialement

Merci Dan,

J'ai testé, mais ca ne donne pas le résultat voulu.

Mais je le garde sous le coude pour plus tard, on ne sait jamais.

Le 26/09/2020 à 09:01

Bonjour

J'ai testé, mais ca ne donne pas le résultat voulu.

Ok mais vous ne dites pas ce qui pose souci. Ne fusses que pour savoir même si vous gardez le code sous le coude

Cordialement

Le 26/09/2020 à 10:56
Dan a écrit :

Bonjour

J'ai testé, mais ca ne donne pas le résultat voulu.

Ok mais vous ne dites pas ce qui pose souci. Ne fusses que pour savoir même si vous gardez le code sous le coude

Cordialement

Oui désolé,

En fait a chaque fin de colonne de catégorie, il y a un saut a la ligne dans les étiquettes,

ce qui me donnent parfois des étiquettes blanches.

Ce que je souhaitais c'était de remplir toutes les étiquettes a la suite.

Le 26/09/2020 à 11:20

Bonjour,

Je suis pas sûr de moi mais, pour le saut de ligne, je crois qu'il suffit de rajouter Option Base 1 en haut du module, avant le code de Dan.

Cdlt,

Le 28/09/2020 à 16:46

Bonjour

En fait a chaque fin de colonne de catégorie, il y a un saut a la ligne dans les étiquettes, ce qui me donnent parfois des étiquettes blanches.

Ok. essayez avec ce code :

Sub Etiquettes()
Dim tablo()
Dim dcl As Integer, dlg As Integer, i As Integer, j As Integer, lig As Integer
Dim Ws As Worksheet

Set Ws = Worksheets("Importation")

On Error Resume Next
Sheets("Etiquettes à imprimer").Cells.Delete
On Error GoTo 0

dcl = Ws.Cells(1, Ws.Columns.Count).End(xlToLeft).Column

For j = 1 To dcl
    dlg = Ws.Cells(Ws.Rows.Count, j).End(xlUp).Row

    ReDim tablo(1 To dlg, 1 To 2)

    For i = 1 To dlg
        tablo(i, 1) = Ws.Cells(i, j)
    Next i
    With Sheets("Etiquettes à imprimer")
        lig = .Range("G" & .Rows.Count).End(xlUp).Row
        If lig > 1 Then lig = lig + 1
        .Range("G" & lig & ":G" & lig + dlg - 1) = tablo
    End With
Next j

j = 1
With Sheets("Etiquettes à imprimer")
    For i = 1 To lig + 1 Step 6
        Set plage = .Range(.Cells(i, 7), .Cells(i + 5, 7))
        .Cells(j, 1).Resize(1, 6) = Application.Transpose(plage)
        j = j + 1
    Next i
    .Columns(7).EntireColumn.Delete
    With .Cells
        .EntireRow.AutoFit
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
End With

End Sub

Cordialement

Rechercher des sujets similaires à "remplissage suite"