Aide pour bien adapter la macro

[Haytoch]

Bonjour,

j'ai essayé de programmer une petite macro pour crée des étiquettes avec une manière très basique .

mon probléme c'est que je peux pas faire la macro tournner sur seulement les quatres premiére Colonne (A.D.C et D) ==> taille d'une feuille A4 .

pour les premiéres étiquettes c'est bonne , mais pour le reste il me mis des une en bas des autre seulement pour la derniére colonne (D)

Sub Manuf_Teckets()
Dim Bws As Worksheet, Dws As Worksheet, C7ws As Worksheet, Mdl As Worksheet
Dim i As Long, C7_Line As Long, j As Integer, k As Integer

Set Mdl = Sheets("Model")
Set Bws = Sheets("BDD")
Set Dws = Sheets("Teckets")
Set C7ws = Sheets("Exemple")

With Dws
'Taille des etiquétes 4C/1999L
    .Columns("A:D").Delete 'clean
    .Columns("A:D").ColumnWidth = 22.57
    .Rows("2:2000").RowHeight = 144 / 3
End With
With C7ws
k = 2
j = 1
 For i = 2 To .Range("A" & Rows.Count).End(xlUp).Row
     
        Mdl.Range("A1:A3").Copy
                      Dws.Activate
                      Dws.Cells(k, j).Select
                      ActiveSheet.Paste
        
                Key = .Cells(i, 1).Value
                C7_Line = Application.WorksheetFunction.Match(Key, Bws.Range("A:A"), 0)
                  
                  Bws.Range("B" & C7_Line).Copy
                      Dws.Activate
                      Dws.Cells(k, j).Select
                      ActiveSheet.Paste
                      
                      Bws.Range("C" & C7_Line).Copy
                      Dws.Activate
                      Dws.Cells(k + 1, j).Select
                      ActiveSheet.Paste
                    
                      Bws.Range("A" & C7_Line).Copy
                      Dws.Activate
                      Dws.Cells(k + 2, j).Select
                      ActiveSheet.Paste

  'problématique
               If i <= 4 Then
                j = j + 1
                k = k
               Else
                j = j
                k = k + 3
               End If
               
   Next i
                End With
   
End Sub

merci de m'aider.
au bien si vous avez une autre astuce merci .

haytoch salut

 

[Paritec]

Re : Aide pour bien adapter la macro

Bonjour Haytoch le forum
Bon alors j'ai voulu regarder ton problème mais tu as fait une Grossière erreur, tu as joint ton fichier au format xlsx et dans ce type de format les macros ne sont pas sauvegardées
Repasses nous ton fichier au format Xlsm STP avec dans un pavé texte ta demande et les explications et on va te faire cela
a+
papou

 

[Haytoch]

Re : Aide pour bien adapter la macro

bonjour Paritec,

le fichier avec la macro est très lourd donc j'ai fait un exemple. et le code de la macro dans le premier poste
merci

c non j'attacherai le meme fichier avec la macro

 

[Haytoch]

Re : Aide pour bien adapter la macro

bonjour Paritec,

le fichier avec la macro est très lourd donc j'ai fait un exemple. et le code de la macro dans le premier poste
merci

c non j'attacherai le meme fichier avec la macro

 

[Haytoch]

Re : Aide pour bien adapter la macro

bonjour Paritec,

le fichier avec la macro est très lourd donc j'ai fait un exemple. et le code de la macro dans le premier poste
merci

c non j'attacherai le meme fichier avec la macro

 

[Paritec]

Re : Aide pour bien adapter la macro

Bonjour Haytoch le forum
voilà tu modifies comme cela, enfin si j'ai compris ce que tu veux, dans l'exemple tu veux créer 7 étiquettes une ligne de 4 et en dessous les trois autres.
Si tu en as + pas de souci j'en ai tenu compte toujours des étiquettes sur 4 colonnes
a+
papou

With C7ws
        k = 2
        j = 1
        For i = 2 To .Range("A" & Rows.Count).End(xlUp).Row
            Mdl.Range("A1:A3").Copy Dws.Cells(k, j)
            Key = .Cells(i, 1).Value
            C7_Line = Application.WorksheetFunction.Match(Key, Bws.Range("A:A"), 0)
            Bws.Range("B" & C7_Line).Copy Dws.Cells(k, j)
            Bws.Range("C" & C7_Line).Copy Dws.Cells(k + 1, j)
            Bws.Range("A" & C7_Line).Copy Dws.Cells(k + 2, j)
            j = j + 1
            If j = 5 Then j = 1: k = k + 3
        Next i
    End With

 

[Haytoch]

Re : Aide pour bien adapter la macro

bonsoir papou ,

ton code marche nickel comme il faut .

je le fait aussi avec cette manière méme chose comme le votre :

With C7ws
For i = 2 To .Range("A" & Rows.Count).End(xlUp).Row
            f = i - 2
            j = (f Mod 4) + 1
            k = (f \ 4) * 3 + 2
        Mdl.Range("A1:A3").Copy
                      Dws.Activate
                      Dws.Cells(k, j).Select
                      ActiveSheet.Paste

                Key = .Cells(i, 1).Value
                C7_Line = Application.WorksheetFunction.Match(Key, Bws.Range("A:A"), 0)

                  Bws.Range("B" & C7_Line).Copy
                      Dws.Activate
                      Dws.Cells(k, j).Select
                      ActiveSheet.Paste

                      Bws.Range("C" & C7_Line).Copy
                      Dws.Activate
                      Dws.Cells(k + 1, j).Select
                      ActiveSheet.Paste

                      Bws.Range("A" & C7_Line).Copy
                      Dws.Activate
                      Dws.Cells(k + 2, j).Select
                      ActiveSheet.Paste
   Next i
                End With

merci bcp

haytoch

 

[Paritec]

Re : Aide pour bien adapter la macro

Bonjour Haytoch le forum
oui tu peux le faire avec ton code, mais si tu veux avancer en vba il serait bon de lire les codes qui sont fait correctement.
Ton code fonctionne mais tous tes select, et activate, ne servent a rien.
maintenant si tu préfères faire des choses inutiles pas de problèmes pour moi
a+
Papou
exemple:

Bws.Range("A" & C7_Line).Copy
                      Dws.Activate
                      Dws.Cells(k + 2, j).Select
                      ActiveSheet.Paste
'c'est pareil que 
Bws.Range("A" & C7_Line).copy Dws.Cells(k + 2, j)
'Mais sans les select et activate

 

[Haytoch]

Re : Aide pour bien adapter la macro

Ok merci bcp pour ton aide