Multiplier des lignes identiques en changeant les quantités

Bonjour à tous,

J'ai seulement quelques notions en en VBA et j'aurais vraiment de votre aide.

Je m'explique : J’ai 1 base qui correspond à des commandes globales annuelles.

J’ai besoin de créer dans un onglet différent 1 ligne par commande journalières mais je voudrais ne pas le faire ligne par ligne.

Vous trouverez ci-joint 1 exemple de fichier avec un onglet « base » et un onglet « résultat souhaité ».

Je voulais avoir si c’était possible à faire avec une macro afin d'obtenir le même résultat que dans l'onglet "résultat souhaité"?

Merci d'avance

Bonsoir ric49, le forum

A tester :

Option Explicit

Sub test()
Dim a, b(), i As Long, n As Long, j As Byte, k As Byte, NbreCde As Byte
    Application.ScreenUpdating = False
    With Sheets("base").Range("A1").CurrentRegion
        a = Application.Index(.Value, Evaluate("row(1:" & _
                                               .Rows.Count & ")"), Array(1, 2, 3, 4, 8, 6, 7, 9))
    End With
    'Attention à la 1ère dimension
    ReDim b(1 To 1000, 1 To UBound(a, 2))
    b(1, 1) = "Intitulé": b(1, 2) = "Code client": b(1, 3) = "Type"
    b(1, 4) = "Date": b(1, 5) = "Quantité": b(1, 6) = "Nbre de camions"
    b(1, 7) = "Commande": b(1, 8) = "Nbre"
    n = 1
    For i = 2 To UBound(a, 1)
        NbreCde = a(i, 8)
        For j = 1 To NbreCde
            n = n + 1
            For k = 1 To UBound(a, 2) - 1
                b(n, k) = a(i, k)
            Next
            b(n, 8) = j
        Next
    Next
    'Restitution en Feuil2
    With Sheets(2)
        .Cells.Clear
        With .Cells(1)
            .Resize(n, UBound(b, 2)).Value = b
            With .CurrentRegion
                With .Rows(1)
                    .BorderAround Weight:=xlThin
                    .Interior.ColorIndex = 44
                End With
                .Font.Name = "calibri"
                .Font.Size = 10
                .BorderAround Weight:=xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                .VerticalAlignment = xlCenter
                .HorizontalAlignment = xlCenter
                .Columns.AutoFit
            End With
        End With
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Merci Klin89 pour cette réponse.

La macro fonctionne mais pas au-delà de 254 commandes. Cependant, parfois, j’ai besoin de dupliquer 1 ligne de ma base en 5000 lignes sur l’onglet suivant. J'ai mis un exemple en fichier-joint.

Que faut il changer dans ta macro ?

Merci t’avance pour ton aide.

Re ric49,

Déclare ces 2 variables en Long

j As Byte, NbreCde As Byte

Et fixe la valeur de la 1ère dimension de la variable tableau b en fonction de tes besoins.

ReDim b(1 To 1000, 1 To UBound(a, 2))

Le code réajusté :

Option Explicit

Sub test()
Dim a, b(), i As Long, n As Long, j As Long, k As Byte, NbreCde As Long, x As Long
    Application.ScreenUpdating = False
    With Sheets("base").Range("A1").CurrentRegion
        a = Application.Index(.Value, Evaluate("row(1:" & _
                                               .Rows.Count & ")"), Array(1, 2, 3, 4, 8, 6, 7, 9))
        x = Application.Sum(.Columns(9)) + 1
    End With
    'Attention à la 1ère dimension
    ReDim b(1 To x, 1 To UBound(a, 2))
    b(1, 1) = "Intitulé": b(1, 2) = "Code client": b(1, 3) = "Type"
    b(1, 4) = "Date": b(1, 5) = "Quantité": b(1, 6) = "Nbre de camions"
    b(1, 7) = "Commande": b(1, 8) = "Nbre"
    n = 1
    For i = 2 To UBound(a, 1)
        NbreCde = a(i, 8)
        For j = 1 To NbreCde
            n = n + 1
            For k = 1 To UBound(a, 2) - 1
                b(n, k) = a(i, k)
            Next
            b(n, 8) = j
        Next
    Next
    'Restitution en Feuil2
    With Sheets(3)
        .Cells.Clear
        With .Cells(1)
            .Resize(n, UBound(b, 2)).Value = b
            With .CurrentRegion
                With .Rows(1)
                    .BorderAround Weight:=xlThin
                    .Interior.ColorIndex = 44
                End With
                .Font.Name = "calibri"
                .Font.Size = 10
                .BorderAround Weight:=xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                .VerticalAlignment = xlCenter
                .HorizontalAlignment = xlCenter
                .Columns.AutoFit
            End With
        End With
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Re,

Pour en finir

Option Explicit

Sub test()
Dim a, b(), i As Long, n As Long, j As Long, k As Byte
    Application.ScreenUpdating = False
    With Sheets("base").Range("A1").CurrentRegion
        a = Application.Index(.Value, Evaluate("row(1:" & _
                                               .Rows.Count & ")"), Array(1, 2, 3, 4, 8, 6, 7, 9))
        ReDim b(1 To Application.Sum(.Columns(9)) + 1, 1 To UBound(a, 2))
    End With
    b(1, 1) = "Intitulé": b(1, 2) = "Code client": b(1, 3) = "Type"
    b(1, 4) = "Date": b(1, 5) = "Quantité": b(1, 6) = "Nbre de camions"
    b(1, 7) = "Commande": b(1, 8) = "Nbre"
    n = 1
    For i = 2 To UBound(a, 1)
        For j = 1 To a(i, 8)
            n = n + 1
            For k = 1 To UBound(a, 2) - 1
                b(n, k) = a(i, k)
            Next
            b(n, 8) = j
        Next
    Next
    'Restitution en Feuil2
    With Sheets(2)
        .Cells.Clear
        With .Cells(1)
            .Resize(n, UBound(b, 2)).Value = b
            With .CurrentRegion
                With .Rows(1)
                    .BorderAround Weight:=xlThin
                    .Interior.ColorIndex = 44
                End With
                .Font.Name = "calibri"
                .Font.Size = 10
                .BorderAround Weight:=xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                .VerticalAlignment = xlCenter
                .HorizontalAlignment = xlCenter
                .Columns.AutoFit
            End With
        End With
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Merci pour ton aide Klin89.

Ta macro fonctionne parfaitement.