1
votes

Copier des lignes plusieurs fois (données dans une cellule)

J'ai une table contenant des données (ProductName, ProductId)

Table Excel

Je voudrais créer un nouvel ensemble de données sur la même feuille. La macro copie les données de la table et insère des lignes sur la colonne D X fois. Les données doivent ressembler à ceci si X est 4:

Sortie souhaitée

Voici un extrait de mon code:

Sub Practice_Loop()
Dim Product As Long, i As Long, j As Long

Country = Range("A2:A10").End(xlUp).Row
For i = Product To 12
    For j = 1 To Range("A" & i).Offset(, 2).Value
       LRow2 = Range("N14" & Rows.Count).End(xlUp).Offset(1).Row
        Range("M14").Value = Range("A2" & i).Value
        Range("N11" & "LRow2").Value = Range("N2:N13" & i).Value & j
    Next j
Next i
End Sub

excel vba

6 commentaires

Pourquoi ne pas utiliser une variable Counter pour trouver le bas de la plage, ou Cells (Rows.Count, 4) .End (xlUp) .Offset (1,0) pour trouver la prochaine cellule vide?

Comment est déterminé «x»?

Sans rapport: pourquoi utilisez-vous des variables nommées i et j au lieu de quelque chose de plus significatif?

Alors, quelle est votre question?

Essayez de définir la boucle

où utilisez-vous votre variable "pays"? Et qu'y a-t-il dans les colonnes M et N?

5 Réponses :

3
votes

Peut-être quelque chose comme ça?

Sub test()
tr = Columns(1).Rows.Count 'total row
Set Rng = Range("A2", Range("A" & tr).End(xlUp))
x = Application.InputBox("How many times ?")
If x = False Or x = "" Then Exit Sub
For Each cell In Rng
For i = 1 To x
Range(cell, cell.Offset(0, 1)).Copy Destination:=Range("D" & tr).End(xlUp).Offset(1, 0)
Next i
Next cell
End Sub

4 commentaires

Ça a l'air correct mais quelques points - (1) J'utiliserais end (xlup) juste au cas où il n'y aurait rien sous A2 et (2) utiliserais rows.count plutôt que hardcoding 1000000. Et pensez peut-être à déclarer vos variables.

Merci beaucoup SJR pour votre suggestion. J'apprécie beaucoup.

Joli. Qu'est-ce que vous utilisez pour réaliser l'animation?

@VBasic, j'utilise le freeware ShareX :)

1
votes

Le code ci-dessous serait considéré comme une version de luxe de ce que vous vouliez en raison des 5 constantes que vous pouvez définir à son sommet. Vous pouvez avoir un ou plusieurs en-têtes, 2 ou plusieurs colonnes de données et définir le nombre de lignes que vous souhaitez pour chacune. Veuillez suivre les instructions dans les commentaires. C'est aussi très rapide.

Sub Practice_Loop()

    ' FirstDataRow is the first row in your sheet below whatver captions there might be
    Const FirstDataRow As Long = 2              ' change to suit
    ' ClmCount is the number of columns to copy from the original data
    '   columns must be adjacent
    Const ClmCount As Long = 2                  ' change to suit
    ' SourceClm is the first of ClmCount columns
    '   containing the source data
    Const SourceClm As Long = 1                 ' 1 = column A, change to suit
    ' TargetClm is the first of ClmCount adjacent columns
    '   to contain the new dataset
    Const TargetClm As Long = 4                 ' 4 = column D, change to suit
    ' Multiplier is the number of duplicate rows (incl original)
    '   that will be created in the output dataset
    Const Multiplier As Integer = 3             ' change to suit

    Dim ArrIn As Variant                        ' input data (from source)
    Dim ArrOut As Variant                       ' ouput data (to target)
    Dim Rt As Long                              ' Target row (to write to)
    Dim Rs As Long                              ' Source row to read from
    Dim C As Long                               ' Source column
    Dim m As Integer                            ' multiplier counter

    With Worksheets("Sheet1")                   ' rename to suit
        ' for greater speed, read all data into an array
        ArrIn = .Range(.Cells(FirstDataRow, SourceClm), .Cells(.Rows.Count, SourceClm) _
                                             .End(xlUp).Offset(0, ClmCount - 1)).Value
        ReDim ArrOut(1 To (UBound(ArrIn) * Multiplier), 1 To ClmCount)
        For Rs = 1 To UBound(ArrIn)
            For m = 1 To Multiplier
                Rt = Rt + 1
                For C = 1 To ClmCount
                    ArrOut(Rt, C) = ArrIn(Rs, C)
                Next C
            Next m
        Next Rs

        ' copy headers, if any
        If FirstDataRow > 1 Then
            .Cells(1, SourceClm).Resize(FirstDataRow - 1, ClmCount).Copy _
                  Destination:=.Cells(1, TargetClm)
        End If
        ' paste the result
        .Cells(FirstDataRow, TargetClm).Resize(UBound(ArrOut), UBound(ArrOut, 2)).Value = ArrOut
    End With
End Sub

La seule chose que ce code ne peut pas faire est de mettre le nouvel ensemble de données sur une autre feuille. Cela nécessiterait une modification.

0 commentaires

2
votes

En effet, vous n'avez pas besoin d'une double boucle pour y parvenir (je suppose que chaque nom de produit associé à un ID de produit et le nom de produit sont uniques):

Sub Practice_Loop()
    Dim x As Long
    Dim rng As Range, target As Range

    x = 4

    Set rng = Cells(Rows.Count, 1).End(xlUp)
    Set rng = rng.Offset(2 - rng.Row).Resize(rng.Row - 1, 2)
    Set target = Cells(2, 4).Resize(rng.Rows.Count * x, 1)  ' paste the list x times
    rng.Copy target

    ' then sort the list based on your original order
    Application.AddCustomList rng
    target.Sort key1:=[D1], order1:=1, ordercustom:=Application.CustomListCount + 1
    Application.DeleteCustomList Application.CustomListCount

    ' copy the header
    Range("A1:B1").Copy Range("D1")

End Sub

1 commentaires

Essayez d'enregistrer Excel après avoir exécuté ce code.

1
votes

Copier des lignes plusieurs fois

Ajustez les valeurs dans la section des constantes. Jouez avec le formatage dans la 2ème version. Etudiez la 3ème version.

MODIFIER:

Lorsque ces constantes vous mettent en scène, il vous vient à l'esprit de créer un sous-argument 'argumenté':

Option Explicit

Sub Practice_Loop()

    Const NameColumn As Long = 1        ' Product Name Column Number
    Const IdColumn As Long = 2          ' Product ID Column Number
    Const HeaderRow As Long = 1         ' Headers Row Number
    Const TargetCell As String = "D1"   ' Target First Cell Range Address
    Const Multiplier As Long = 4        ' Multiplier

    Dim rng As Range              ' Last Non-Empty Cell Range,
                                  ' Non-Empty Column Range in Name Column,
                                  ' Non-Empty Column Range in ID Column
    Dim ProductName As Variant    ' Product Name Array
    Dim ProductID As Variant      ' Product ID Array
    Dim Target As Variant         ' Target Array
    Dim i As Long                 ' Product Name/ID Elements (Rows) Counter
    Dim j As Long                 ' Multiplier Counter
    Dim k As Long                 ' Target Array Elements (Rows) Counter

    ' Write values from Ranges to Arrays.
    Set rng = Columns(NameColumn).Find(What:="*", LookIn:=xlFormulas, _
      SearchDirection:=xlPrevious)
    If rng Is Nothing Then Exit Sub
    Set rng = Range(Cells(HeaderRow, NameColumn), rng)
    ProductName = rng
    Set rng = rng.Offset(, IdColumn - NameColumn)
    ProductID = rng
    Set rng = Nothing

    ' Define Target Array.
    ReDim Target(1 To UBound(ProductName) * Multiplier + 1, 1 To 2)

    ' Write headers from Arrays to Target Array.
    Target(1, 1) = ProductName(1, 1)
    Target(1, 2) = ProductID(1, 1)

    ' Write values from Arrays to Target Array.
    k = 2 ' Headers are in row 1.
    For i = 2 To UBound(ProductName)
        For j = 1 To Multiplier
            Target(k, 1) = ProductName(i, 1)
            Target(k, 2) = ProductID(i, 1)
            k = k + 1
        Next j
    Next i

    ' Write values from Target Array to Target Range.
    Set rng = Range(TargetCell).Resize(UBound(Target), 2)
    'rng.EntireColumn.ClearContents
    rng = Target

End Sub



Sub Practice_Loop_With_Formatting()

    Const NameColumn As Long = 1        ' Product Name Column Number
    Const IdColumn As Long = 2          ' Product ID Column Number
    Const HeaderRow As Long = 1         ' Headers Row Number
    Const TargetCell As String = "D1"   ' Target First Cell Range Address
    Const Multiplier As Long = 4        ' Multiplier

    Dim rng As Range              ' Last Non-Empty Cell Range,
                                  ' Non-Empty Column Range in Name Column,
                                  ' Non-Empty Column Range in ID Column
    Dim ProductName As Variant    ' Product Name Array
    Dim ProductID As Variant      ' Product ID Array
    Dim Target As Variant         ' Target Array
    Dim i As Long                 ' Product Name/ID Elements (Rows) Counter
    Dim j As Long                 ' Multiplier Counter
    Dim k As Long                 ' Target Array Elements (Rows) Counter

    ' Write values from Ranges to Arrays.
    Set rng = Columns(NameColumn).Find(What:="*", LookIn:=xlFormulas, _
      SearchDirection:=xlPrevious)
    If rng Is Nothing Then Exit Sub
    Set rng = Range(Cells(HeaderRow, NameColumn), rng)
    ProductName = rng
    Set rng = rng.Offset(, IdColumn - NameColumn)
    ProductID = rng
    Set rng = Nothing

    ' Define Target Array.
    ReDim Target(1 To UBound(ProductName) * Multiplier + 1, 1 To 2)

    ' Write headers from Arrays to Target Array.
    Target(1, 1) = ProductName(1, 1)
    Target(1, 2) = ProductID(1, 1)

    ' Write values from Arrays to Target Array.
    k = 2 ' Headers are in row 1.
    For i = 2 To UBound(ProductName)
        For j = 1 To Multiplier
            Target(k, 1) = ProductName(i, 1)
            Target(k, 2) = ProductID(i, 1)
            k = k + 1
        Next j
    Next i

    ' Define Target Range.
    Set rng = Range(TargetCell).Resize(UBound(Target), 2)
    'rng.EntireColumn.ClearContents
    ' Write values from Target Array to Target Range.
    rng = Target

    ' Apply formatting.
    With rng
        ' Format Target Range here, in between the other with statements
        ' and/or after all the other with statements...
        .EntireColumn.AutoFit
        With .Rows(1)
            ' Format Headers here...
            .Font.Bold = True
        End With
        With .Cells(1).Offset(1).Resize(.Rows.Count - 1, .Columns.Count)
            ' Format 'Body' Range (Data (below Headers)) here...
        End With
        With .Cells(1).Offset(1).Resize(.Rows.Count - 1)
            ' Format First Column (ProductName) of 'Body' Range (Data) here...
        End With
        With .Cells(2).Offset(1).Resize(.Rows.Count - 1)
            ' Format Second Column (ProductID) of 'Body' Range (Data) here...
        End With
    End With

End Sub



Sub Practice_Loop_Study()

    Const NameColumn As Long = 1        ' Product Name Column Number
    Const IdColumn As Long = 2          ' Product ID Column Number
    Const HeaderRow As Long = 1         ' Headers Row Number
    Const TargetCell As String = "D1"   ' Target First Cell Range Address
    Const Multiplier As Long = 4        ' Multiplier

    Dim rng As Range              ' Last Non-Empty Cell Range,
                                  ' Non-Empty Column Range in Name Column,
                                  ' Non-Empty Column Range in ID Column
    Dim ProductName As Variant    ' Product Name Array
    Dim ProductID As Variant      ' Product ID Array
    Dim Target As Variant         ' Target Array
    Dim i As Long                 ' Product Name/ID Elements (Rows) Counter
    Dim j As Long                 ' Multiplier Counter
    Dim k As Long                 ' Target Array Elements (Rows) Counter

Debug.Print String(50, "-") & vbCrLf & "Before:"
    ' Define Last Non-Empty Cell Range in Name Column,
    Set rng = Columns(NameColumn).Find(What:="*", LookIn:=xlFormulas, _
      SearchDirection:=xlPrevious)
Debug.Print "Last Non-Empty Cell Range Address = " & rng.Address
    ' Check if any data in Name Column.
    If rng Is Nothing Then Exit Sub
    ' Define Non-Empty Column Range in Name Column.
    Set rng = Range(Cells(HeaderRow, NameColumn), rng)
Debug.Print "Product Name Range Address        = " & rng.Address
    ' Write values from Product Name Range to Product Name Array.
    ProductName = rng
    ' Define Non-Empty Column Range in ID Column.
    Set rng = rng.Offset(, IdColumn - NameColumn)
Debug.Print "Product ID Range Address          = " & rng.Address
    ' Write values from Product ID Range to Product ID Array.
    ProductID = rng
    ' Range not needed any more.
    Set rng = Nothing

    ' Define Target Array.
    ReDim Target(1 To UBound(ProductName) * Multiplier + 1, 1 To 2)

    ' Write headers from Arrays to Target Array.
    Target(1, 1) = ProductName(1, 1)
    Target(1, 2) = ProductID(1, 1)

    ' Write values from Arrays to Target Array.
    k = 2 ' Headers are in row 1.
    For i = 2 To UBound(ProductName)
        For j = 1 To Multiplier
            Target(k, 1) = ProductName(i, 1)
            Target(k, 2) = ProductID(i, 1)
            k = k + 1
        Next j
    Next i

    ' Define Target Range.
    Set rng = Range(TargetCell).Resize(UBound(Target), 2)
    'rng.EntireColumn.ClearContents
    ' Write values from Target Array to Target Range.
    rng = Target

Debug.Print String(50, "-") & vbCrLf & "After:"
    ' Apply formatting.
    With rng
Debug.Print "Target Range Address              = " & .Address
        ' Format Target Range here, in between the other with statements
        ' and/or after all the other with statements...
        .EntireColumn.AutoFit
        With .Rows(1)
Debug.Print "Headers Address                   = " & .Address
            ' Format Headers here...
            .Font.Bold = True
        End With
        With .Cells(1).Offset(1).Resize(.Rows.Count - 1, .Columns.Count)
Debug.Print "'Body' Range Address              = " & .Address
            ' Format 'Body' Range (Data (below Headers)) here...
        End With
        With .Cells(1).Offset(1).Resize(.Rows.Count - 1)
Debug.Print "Product Name Range Address        = " & .Address
            ' Format First Column (ProductName) of 'Body' Range (Data) here...
        End With
        With .Cells(2).Offset(1).Resize(.Rows.Count - 1)
Debug.Print "Product ID Range Address          = " & .Address
            ' Format Second Column (ProductID) of 'Body' Range (Data) here...
        End With
    End With

End Sub

et utilisez-le dans un autre sous comme celui-ci:

Sub Other()
    Practice_LoopA 1, 2, 1, "D1", 4
End Sub

Solution initiale p>

Sub Practice_LoopA(NameColumn As Long, IdColumn As Long, HeaderRow As Long, _
  TargetCell As String, Multiplier As Long)
'...
End Sub

0 commentaires

0
votes

Essayez ce code en utilisant des tableaux qui seraient plus rapides que l'approche habituelle de la copie

Sub Test()
    Dim a, i As Long, j As Long, k As Long
    Const n As Integer = 3
    a = Range("A2:B" & Cells(Rows.Count, 1).End(xlUp).Row).Value
    ReDim b(1 To UBound(a) * n, 1 To UBound(a, 2))
    For i = 1 To UBound(a)
        For j = 1 To n
            k = k + 1
            b(k, 1) = a(i, 1)
            b(k, 2) = a(i, 2)
        Next j
    Next i
    With Range("E1")
        .Resize(1, 2).Value = Array("Product Name", "Product ID")
        .Offset(1).Resize(UBound(b), UBound(b, 2)).Value = b
    End With
End Sub

0 commentaires