Macro duppliquer lignes quand plusieurs codes produits dans

Le 11/08/2017 à 12:13

Bonjour les pros de la macro,

Je voudrais créer une macro qui vient copier les lignes qui comportent plusieurs numéros de codes produits en dupliquant les autres colonnes de la ligne comme suit :

macro
  • Les codes produits font toujours 7 caractères et sont séparés d’un espace
  • Les codes doivent être ajoutés les un en dessous des autres : un code par ligne
  • Toutes les autres colonnes doivent être copiées
  • Le nombre de code produits par cellules varient entre 1 et 100
  • La macro devrait fonctionner pour un grand nombre de ligne

Pour le moment ma macro ne marche pas, pourriez-vous m’aider à la faire fonctionner ?

Sub lignesCodesproduits ()

Dim h as string

Dim i as integer

For j = range(“A65536”)>End(x1up).Row to Step -1

Do while Len(cells(i,4)) > 8

For i = 1 to 100

Value.cells(i,4) = h

Rows(i).InsertShift=x1Down

Rows(i+1).CopyRows(i)

cells(i+1,4)=mid(cells(i,4),7,(len(cells(i,4))-7))

cells(i,4)=left(h(i,8))

i = i+1

Next

Loop

Next

End Sub ()

13exemple-court.xlsm (9.87 Ko)

Merci milles fois ))))))))))))))

Le 11/08/2017 à 12:34

Bonjour,

Ci-joint une proposition à tester.

> Résultat dans l'onglet "Résultat"

Bonne journée

Bouben

17exemple-court-v0-1.xlsm (19.88 Ko)
Le 11/08/2017 à 12:54

Bonjour, Salut Bouben,

Autre proposition :

Sub LignesCodesproduits()
    Dim lp, h, cp%, j%, n&, i&
    With ActiveSheet
        n = .Cells(.Rows.Count, 1).End(xlUp).Row
        Application.ScreenUpdating = False
        .Range("A2:E" & n).Borders.LineStyle = xlLineStyleNone
        For i = n To 2 Step -1
            lp = .Cells(i, 1).Resize(, 5).Value
            h = Split(" " & lp(1, 4))
            cp = UBound(h)
            If cp > 1 Then
                .Rows(i + 1 & ":" & i + cp - 1).Insert
                For j = 0 To cp - 1
                    lp(1, 4) = h(j + 1)
                    .Cells(i + j, 1).Resize(, 5).Value = lp
                Next j
            End If
        Next i
        n = .Cells(.Rows.Count, 1).End(xlUp).Row
        With .Range("A2:E" & n)
            .BorderAround xlContinuous, xlThin
            .Borders(xlInsideVertical).Weight = xlThin
        End With
    End With
End Sub

Cordialement.

17laurianegrange-exemple-court.xlsm (19.24 Ko)
Le 11/08/2017 à 14:15

Bonjour,

à part ce p$^ùµ§à de redim (si on sait me dire pourquoi ? ) que je ne sais pas faire fonctionner correctement,

ceci semble correspondre

Edit: correction du code avec le "redim"

P.

Option Explicit

Sub Copie()
Dim D1, D2, C, mRange
Dim F1, F2 As Worksheet
Dim Last, I, J, Li, Col As Integer
Dim A(), B()
Dim S, Sp
Set F1 = Sheets("donnees"): Set F2 = Sheets("resultat") ' facilite la sélection des feuilles
F2.[B10:F1000].ClearContents
Last = [A65000].End(xlUp).Row ' dernière ligne occupée de la colonne
Set mRange = Range("A2:A" & Last)
A = F1.[B2].CurrentRegion.Value
Li = 1: Col = 0
For I = 2 To UBound(A)
   Sp = Split(A(I, 4), " ")
   For J = LBound(Sp) To UBound(Sp)
      ' mise dans le tableau
      Li = Li + 1
     ReDim Preserve B(1 to 5 ,1 To Li ) 
      B(1, Li) = A(I, 1) ' colonne 1
      B(2, Li) = A(I, 2)
      B(3, Li) = A(I, 3)
      B(4, Li) = Sp(J)
      B(5, Li) = A(I, 5)
   Next
Next
F2.[B10].CurrentRegion.ClearContents 'effacer la feuille des résultats 
F2.[A10].Resize(UBound(B, 2), 5) = Application.Transpose(B)
End Sub
Le 11/08/2017 à 14:36

Salut Patrick,

Quel est ton problème avec ReDim ?

Je vois que tu sembles vouloir typer des variables en groupe, or les variables se typent toujours individuellement, donc tes variables F1, Last, I, J, Li sont de type Variant (de même que celles qui ne sont pas typées).

Cordialement.

Le 11/08/2017 à 14:41
MFerrand a écrit :

Salut Patrick,

Quel est ton problème avec ReDim ?

Je vois que tu sembles vouloir typer des variables en groupe, or les variables se typent toujours individuellement, donc tes variables F1, Last, I, J, Li sont de type Variant (de même que celles qui ne sont pas typées).

Cordialement.

Je t'ai envoyé un MP

Le 14/08/2017 à 09:00
bouben a écrit :

Bonjour,

Ci-joint une proposition à tester.

> Résultat dans l'onglet "Résultat"

Bonne journée

Bouben

Ok je test la proposition. Merci beaucoup pour votre aide et votre temps!

MFerrand a écrit :

Bonjour, Salut Bouben,

Autre proposition :

Sub LignesCodesproduits()
    Dim lp, h, cp%, j%, n&, i&
    With ActiveSheet
        n = .Cells(.Rows.Count, 1).End(xlUp).Row
        Application.ScreenUpdating = False
        .Range("A2:E" & n).Borders.LineStyle = xlLineStyleNone
        For i = n To 2 Step -1
            lp = .Cells(i, 1).Resize(, 5).Value
            h = Split(" " & lp(1, 4))
            cp = UBound(h)
            If cp > 1 Then
                .Rows(i + 1 & ":" & i + cp - 1).Insert
                For j = 0 To cp - 1
                    lp(1, 4) = h(j + 1)
                    .Cells(i + j, 1).Resize(, 5).Value = lp
                Next j
            End If
        Next i
        n = .Cells(.Rows.Count, 1).End(xlUp).Row
        With .Range("A2:E" & n)
            .BorderAround xlContinuous, xlThin
            .Borders(xlInsideVertical).Weight = xlThin
        End With
    End With
End Sub

Cordialement.

Cette proposition marche tres bien aussi. Je l'adapte a mon fichier complet. Merci beaucoup !!

patrick1957 a écrit :

Bonjour,

à part ce p$^ùµ§à de redim (si on sait me dire pourquoi ? ) que je ne sais pas faire fonctionner correctement,

ceci semble correspondre

Edit: correction du code avec le "redim"

P.

Option Explicit

Sub Copie()
Dim D1, D2, C, mRange
Dim F1, F2 As Worksheet
Dim Last, I, J, Li, Col As Integer
Dim A(), B()
Dim S, Sp
Set F1 = Sheets("donnees"): Set F2 = Sheets("resultat") ' facilite la sélection des feuilles
F2.[B10:F1000].ClearContents
Last = [A65000].End(xlUp).Row ' dernière ligne occupée de la colonne
Set mRange = Range("A2:A" & Last)
A = F1.[B2].CurrentRegion.Value
Li = 1: Col = 0
For I = 2 To UBound(A)
   Sp = Split(A(I, 4), " ")
   For J = LBound(Sp) To UBound(Sp)
      ' mise dans le tableau
      Li = Li + 1
     ReDim Preserve B(1 to 5 ,1 To Li ) 
      B(1, Li) = A(I, 1) ' colonne 1
      B(2, Li) = A(I, 2)
      B(3, Li) = A(I, 3)
      B(4, Li) = Sp(J)
      B(5, Li) = A(I, 5)
   Next
Next
F2.[B10].CurrentRegion.ClearContents 'effacer la feuille des résultats 
F2.[A10].Resize(UBound(B, 2), 5) = Application.Transpose(B)
End Sub

Merci Patrick pour ta proposition de code, je vais aussi la tester sur mon fichier original. Tres bon travail merci !

Rechercher des sujets similaires à "macro duppliquer lignes quand codes produits"