看看下面的代码。它有两个嵌套循环，外层循环遍历所有数据，内层循环搜索两个连续的空行。当找到这些空行时，创建一个新工作表，复制从startRow到找到的行的数据，并将startRow设置为下一个块的开始。重复此操作，直到所有数据都处理完毕。
代码将相关数据读入内存以加快处理速度，但逻辑保持不变。我还添加了一个小函数来检查整个行是否为空。

Option Explicit

Sub SplitReport(Optional ws As Worksheet = Nothing)
    Const ColCount = 5          ' Define number of rows to check/copy
    
    If ws Is Nothing Then Set ws = ActiveSheet
    Dim wb As Workbook
    Set wb = ws.Parent
    
    Dim row As Long, startRow As Long, lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
    
    ' Read into memory to speed up data (+2 to ensure that we have 2 empty lines at the end.
    Dim data
    data = ws.Cells(1, 1).Resize(lastRow + 2, ColCount).Value
    
    startRow = 1
    Do While startRow < lastRow
        row = startRow
        ' Search for 2 empty rows
        Do While Not isEmptyRow(data, row) Or Not isEmptyRow(data, row + 1)
            DoEvents
            row = row + 1
        Loop
        
        ' Copy data to new sheet
        wb.Worksheets.Add after:=wb.Sheets(wb.Sheets.Count)
        ws.Range(ws.Cells(startRow, 1), ws.Cells(row, ColCount)).Copy wb.ActiveSheet.Cells(1, 1)
        
        ' Start next Block of data
        startRow = row + 2
    Loop
End Sub

Private Function isEmptyRow(data, row As Long) As Boolean
    Dim col As Long
    For col = 1 To UBound(data, 2)
        If Not IsEmpty(data(row, col)) Then Exit Function
    Next
    isEmptyRow = True
End Function