如何将行从一个 Excel 工作表复制到另一个并使用 VBA 创建重复项？
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/12837297/
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
How to copy rows from one excel sheet to another and create duplicates using VBA?
提问by user1737622
I have excel workbook with two sheets: sheet1 has a large table of data in columns A to R, headers at row 1. Sheet2 has data in columns A to AO.
我有两张工作表的 excel 工作簿：sheet1 在 A 到 R 列中有一个大数据表，在第 1 行有标题。 Sheet2 在 A 到 AO 列中有数据。
Using VBA I am trying to copy rows from sheet1 and paste them to the end of sheet2. Also I need to copy only columns A to R, not the entire row.
使用 VBA 我试图从 sheet1 复制行并将它们粘贴到 sheet2 的末尾。此外，我只需要将 A 列复制到 R，而不是整行。
In other words, cells A2:R2 from sheet1 need to be copied to first AND second row that don't have data in column A.
换句话说，sheet1 中的单元格 A2:R2 需要复制到 A 列中没有数据的第一行和第二行。
Any help is highly appreciated!
任何帮助表示高度赞赏！
@AlistairWeir, I have a following code that copies the required cells from sheet1, but I cannot figure out how to copy every row twice.
@AlistairWeir，我有以下代码可以从 sheet1 复制所需的单元格，但我无法弄清楚如何将每一行复制两次。
Sub example()
For Each ce In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
If Not IsEmpty(ce) Then
Sheets("sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 18).Value = Range(ce, ce.Offset(0, 17)).Value
End If
Next ce
End Sub
Sub example()
For Each ce In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
If Not IsEmpty(ce) Then
Sheets("sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 18).Value = Range(ce, ce.Offset(0, 17)).Value
End If
Next ce
End Sub
采纳答案by Alistair Weir
Try this:
尝试这个：
Option Explicit
Sub CopyRows()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim i As Integer, k As Integer
Dim ws1LR As Long, ws2LR As Long
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
ws1LR = ws1.Range("A" & Rows.Count).End(xlUp).Row + 1
ws2LR = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
i = 2
k = ws2LR
Do Until i = ws1LR
With ws1
.Range(.Cells(i, 1), .Cells(i, 18)).Copy
End With
With ws2
.Cells(k, 1).PasteSpecial
.Cells(k, 1).Offset(1, 0).PasteSpecial
End With
k = k + 2
i = i + 1
Loop
End Sub
Change Sheet1and Sheet2if they are called different things in your workbook.
更改Sheet1，Sheet2如果它们在您的工作簿中被称为不同的东西。
