多次复制行（在单元格中给出）
Posted
技术标签:
【中文标题】多次复制行（在单元格中给出）【英文标题】：Copy rows multiple times (given in a cell) 【发布时间】：2020-05-04 07:32:39 【问题描述】：我有一个包含数据（ProductName、ProductId）的表
Excel表格
我想在同一张工作表上创建一个新数据集。该宏将从表中复制数据，并在 D 列上插入行 X 次。如果 X 为 4，数据应该是这样的：
期望的输出
这是我的代码的 sn-p：
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
【问题讨论】：
为什么不使用 Counter 变量查找范围的底部，或者使用Cells(Rows.Count,4).End(xlUp).Offset(1,0) 查找下一个空白单元格？
“x”是如何确定的？
无关：你为什么使用名为 i 和 j 的变量而不是更有意义的变量？
那么，你的问题是什么？
尝试设置循环
【参考方案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
【讨论】：
看起来不错，但有几点-（1）我会使用end(xlup)，以防A2下面没有任何东西，（2）使用rows.count而不是硬编码1000000。也许想想声明你的变量。
非常感谢 SJR 的建议。真的很感激。
不错。你用什么做动画？
@VBasic，我使用免费软件 ShareX :)【参考方案2】：
确实，您不需要双循环来实现这一点（我假设每个产品名称都映射到产品 ID，并且产品名称是唯一的）：
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
【讨论】：
运行此代码后尝试保存 excel .. excel 挂起，应用程序关闭。【参考方案3】：由于您可以在其顶部设置 5 个常量，因此下面的代码可以作为您想要的豪华版本。您可以拥有一个或多个标题、2 个或多个数据列，并为每个列设置所需的行数。请按照 cmets 中的说明进行操作。它也非常快。
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
这段代码唯一不能做的就是将新数据集放在另一张纸上。那需要修改。
【讨论】：
【参考方案4】：多次复制行
调整常量部分中的值。使用第二版中的格式。研究第三版。
编辑：
当这些常量在你面前出现时，你会想到创建一个“有争议的”子：
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
【讨论】：
【参考方案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
【讨论】：
以上是关于多次复制行（在单元格中给出）的主要内容，如果未能解决你的问题，请参考以下文章