vba - Excel VBA 复制和粘贴特定行数和新工作簿

Question

我有一个ContactsforEmails从这个工作簿调用的主工作表，我正在将标题复制到每个新工作簿中。

然后，我从A2直到I列开始每 40 行复制和粘贴一次。新工作簿被保存并关闭。然后我想循环创建另一个新的工作簿名称“EmailList（下一个数字）”，然后复制下一个 40。然后运行直到A列中的下一个单元格为空白。

我设法复制了标题，另存为新文档，然后复制了前 40 个。我还没有弄清楚如何让它正确循环，我怀疑它是使用DoUntil循环和Offset。但我希望在这方面更先进的人可以提供建议。

我遇到的错误是“运行时错误 9：下标超出范围”。

这是我的尝试：

'Copy Header
   Range("A1").Select
   Range(Selection, Selection.End(xlToRight)).Select
   Selection.Copy
   Workbooks.Add
   ActiveSheet.Paste
   Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
   SkipBlanks:=False, Transpose:=False
   Rows("1:1").EntireRow.AutoFit

'Save File As New Name
   Dim fpath As String
   Dim fcount As Integer
   Dim fname As String
   Do While Len(Dir(fpath & fname)) <> 0
     fpath = "C:\Users\Path\"
     fcount = fcount + 1
     fname = "EmailList" & fcount & ".xlsx"
   Loop
   ActiveWorkbook.SaveAs Filename:=fpath & fname
'Copy and Paste 40
  Windows("ContactsForEmails.xlsx").Activate
    Dim fcopy As Range
    Set fcopy = Range("A2:H41")
    fcopy.Select
    Selection.Copy
    Windows(fname).Activate
    Range("A2").Select
    ActiveSheet.Paste
    ActiveWorkbook.Save
    ActiveWorkbook.Close

    Do Until IsEmpty(fcopy)
     fcopy.Offset(40, 0).Select
     Selection.Copy
     Windows(fname).Activate
     Range("A2").Select
     ActiveSheet.Paste
     ActiveWorkbook.Save
     ActiveWorkbook.Close
   Loop

End Sub

标签： vbaexcelcopy-paste