用于添加工作表的Excel VBA循环

我目前正试图找出如何创建一个基于活动工作表中行数的循环。 我正在创建一个数据转换器，我正在转换的数据最多只能是4000行。我的源数据大小可能不同，因此我需要能够计算活动工作表上的行数，如果行数超过4000，则创建一个新工作表（以数字递增的名称，例如Output1、Output2等），返回到我正在计算的工作表，将行4001剪切到末尾，并将其粘贴到新工作表上。循环应重复，直到计数小于4001并结束

我已经编写了创建输出的部分，我只需要能够将输出拆分为不超过4000行的“x”数量的纸张

下面是我已经走了多远，我只是无法破解循环元素！谢谢你抽出时间

    LastRow2 = Range("A1").CurrentRegion.Rows.Count
    If LastRow2 > 4000 Then
    Name = Right(ws.Name, 1)
    Sheets.Add.Name = "Output1" & Name
    ActiveSheet.Previous.Select
    Range("A4001").End(xlDown).Select
    Selection.Cut
    ActiveSheet.Next.Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
         :=False, Transpose:=False
    Else: GoTo

---

创建一个循环，以4000为增量将行复制到新工作表，并在循环结束后从起始工作表中删除其余行

---

---

创建一个循环，以4000为增量将行复制到新工作表，并在循环结束后从起始工作表中删除其余行

---

---

对于i=4001到lr步骤4000

？是否要复制标题？

对于i=4001到lr步骤4000

？是否要复制标题？非常感谢。非常感谢，非常感谢。谢谢。

Sub shelter_in_place()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim ns As Worksheet

Dim lr As Long, i As Long, c As Long
lr = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
c = 1


If lr > 4000 Then
    For i = 4001 To lr Step 4000
        Set ns = Worksheets.Add(After:=Sheets(ThisWorkbook.Sheets.Count))
            ns.Name = "Output " & c
            ws.Range("A" & i).Resize(4000).EntireRow.Copy
            ns.Range("A1").PasteSpecial xlPasteValues
            c = c + 1
        Set ns = Nothing
    Next i
  ws.Range("A4001:A" & lr).EntireRow.Delete
End If

End Sub