Копировать строки несколько раз (задано в ячейке)

Question

У меня есть таблица, содержащая данные (ProductName, ProductId)

Таблица Excel

Я хочу создать новый набор данных на том же листе. Макрос будет копировать данные из таблицы и вставлять строки в столбец DX раз. Данные должны выглядеть следующим образом, если X равно 4:

Желаемый вывод

Вот фрагмент моего кода:

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

Answer 1

Может быть как то так?

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

Answer 2

Действительно, вам не нужно двойное l oop для достижения этого (я предполагаю, что каждое Имя продукта сопоставлено с Идентификатором продукта, а Имя продукта уникально):

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

Answer 3

Несколько строк копирования

Настройте значения в разделе констант. Поиграйте с форматированием во 2-й версии. Изучите 3-ю версию.

РЕДАКТИРОВАТЬ:

Когда эти константы играют главную роль в вашем лице, возникает мысль создать аргументированную подпункт:

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

и используйте его в другом подпрограмме, например:

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

Начальное решение

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

Answer 4

Приведенный ниже код будет рассматриваться как де-люкс версия того, что вы хотели, из-за 5 констант, которые вы можете установить в верхней его части. Вы можете иметь один или несколько заголовков, 2 или несколько столбцов данных и установить количество строк, которое вы хотите для каждого. Пожалуйста, следуйте инструкциям в комментариях. Это также очень быстро.

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

Единственное, что этот код не может сделать, - это поместить новый набор данных на другой лист. Это потребует модификации.

Answer 5

Попробуйте этот код, используя массивы, которые будут быстрее, чем обычный метод копирования

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