Excel VBA Копирование и вставка определенного количества строк и новой рабочей книги

Question

У меня есть мастер лист под названием ContactsforEmails из этой книги, я копирую заголовок в каждую новую книгу.

Затем я копирую и вставляю каждые 40 строк, начиная с A2 до I столбца. Новая рабочая книга сохранена и закрыта. Затем я хочу вернуться назад, создать еще одну новую книгу с именем «EmailList (next number)» и скопировать следующие 40. Затем выполнить до тех пор, пока следующая ячейка в столбце A не станет пустой.

Мне удалось скопировать заголовок, сохранить как новый документ и скопировать первые 40. Я не понял, как сделать это правильно, я подозреваю, что это с DoUntil loop и 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