将每10个Excel行复制并粘贴到另一个工作簿循环中

从100行的Excel工作簿（original_workbook.xlsx）（或任意数量的行，最好）。

我想要一个macros，将每10行复制并粘贴到一个名为Workbook_ [date] _ [random number] .xlsx的新Excel工作簿中。

注意：original_workbook.xlsx的第一行是每个新工作簿的标题。 使用录制的macros，到目前为止，我有以下VB代码：

Workbooks.Add ActiveWorkbook.SaveAs Filename:= _ "C:\path\Workbook_[date]_[random number].xlsx", FileFormat:= _ xlOpenXMLWorkbook, CreateBackup:=False Windows("original_workbook.xlsx").Activate Rows("1:1").Select Selection.Copy Windows("Workbook_[date]_[random number].xlsx").Activate ActiveSheet.Paste Windows("original_workbook.xlsx").Activate Rows("2:11").Select Application.CutCopyMode = False Selection.Copy Windows("Workbook_[date]_[random number].xlsx").Activate Range("A2").Select ActiveSheet.Paste Range("A2").Select Application.CutCopyMode = False ActiveWorkbook.Save Windows("original_workbook.xlsx").Activate Windows("Workbook_[date]_[random number].xlsx").Activate 

我想上面的代码循环，直到没有更多的行左。

我怀疑Rows("2:11").Select将需要改变。 我抬起头来为我，但它不工作。 谢谢。

Answer 1

logging一个macros是一个很好的方式来获得框架和一个certificate中涉及的个别命令的一些想法，但是由此产生的代码可能在一些地方是冗长的而在其他地方是缺乏的。

您录制的macros特别缺less正在复制和粘贴的工作表名称。 这不是录音的一部分，因为他们已经是活跃的工作表了 。 为了下面的代码的目的，我简单地在两个工作簿上使用Sheet1 。

 Dim rw As Long, nwb As Workbook, owb As Workbook Set owb = Windows("original_workbook.xlsx") Set nwb = Workbooks.Add nwb.SaveAs Filename:= _ "C:\path\Workbook_[date]_[random number].xlsx", FileFormat:= _ xlOpenXMLWorkbook, CreateBackup:=False With owb.Sheets("Sheet1") .Rows("1:1").Copy _ Destination:=nwb.Sheets("Sheet1").Range("A1") For rw = 2 To 92 Step 10 .Cells(rw, 1).Resize(10, 1).EntireRow.Copy _ Destination:=nwb.Sheets("Sheet1").Range("A2").Offset(rw, 0) Next rw nwb.Save .Activate End With nwb.Activate 

我已经build立了一个循环，但真的不清楚你想要的结果。 如果将它们堆叠在一起，那么只需一次复制和粘贴它们将是非常容易的。

请参阅如何避免使用Excel中的selectVBAmacros来获取更多的方法来摆脱依靠select和activate来实现您的目标。