vba 根据列中的值复制和插入行
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/19504741/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Copy and insert rows based off of values in a column
提问by Ship72
I am trying to set up a procedure that looks up cells in Column "G" and if a value is greater than 1, copy that entire table row, insert a row (as many times - 1 based on the value) and paste that value into each newly inserted row.
我正在尝试设置一个过程来查找列“G”中的单元格，如果值大于 1，则复制整个表格行，插入一行（多次 - 基于值的 1）并粘贴该值到每个新插入的行中。
So if there is a quantity of 3 in cell "G4" then I would like to copy the row of that cell and insert a row below it 2 times and paste the copied values.
因此，如果单元格“G4”中的数量为 3，那么我想复制该单元格的行并在其下方插入一行 2 次并粘贴复制的值。
Below is what I have so far...
以下是我到目前为止...
**Note all of this is in a table in Excel. (not sure if that's part the issue with my code)
**请注意，所有这些都在 Excel 表格中。（不确定这是否是我的代码问题的一部分）
Dim Qty As Range
For Each Qty In Range("G:G").cells
If Qty.Value > 1 Then
Qty.EntireRow.cell
Selection.Copy
ActiveCell.Offset(1).EntireRow.Insert
Selection.Paste
Selection.Font.Strikethrough = True
End If
Next
End Sub
采纳答案by chris neilsen
There are a number of issues with your approach and code
您的方法和代码存在许多问题
- You say the data is in an Excel Table. Use that to your advantage
- When inserting rows into a range loop from the bottom up. This prevents the inserted rows interfering with the loop index
- Don't use
Selection(and even if you do your logic doesn't manipulate the ActiveCell) - Don't loop over the whole column (thats a million rows). Limit it to the table size
- 您说数据在 Excel 表格中。充分利用它
- 从下往上将行插入范围循环时。这可以防止插入的行干扰循环索引
- 不要使用
Selection（即使你做了你的逻辑也不会操作 ActiveCell） - 不要遍历整列（那是一百万行）。将其限制为表格大小
Here's a demonstration of these ideas
这是这些想法的演示
Sub Demo()
Dim sh As Worksheet
Dim lo As ListObject
Dim rColumn As Range
Dim i As Long
Dim rws As Long
Set sh = ActiveSheet ' <-- adjuct to suit
Set lo = sh.ListObjects("YourColumnName")
Set rColumn = lo.ListColumns("YourColumnName").DataBodyRange
vTable = rColumn.Value
For i = rColumn.Rows.Count To 1 Step -1
If rColumn.Cells(i, 1) > 1 Then
rws = rColumn.Cells(i, 1) - 1
With rColumn.Rows(i)
.Offset(1, 0).Resize(rws, 1).EntireRow.Insert
.EntireRow.Copy .Offset(1, 0).Resize(rws, 1).EntireRow
.Offset(1, 0).Resize(rws, 1).EntireRow.Font.Strikethrough = True
End With
End If
Next
End Sub
