VBAでシートを指定行数ごとに分割して複数ファイルへ保存する

Private Sub CopyDataToNewFiles()
    Const maxRows As Long = 1000
    Const newFileName As String = "NewFile_"
    Dim newWb As Workbook
    Dim ws As Worksheet, newWs As Worksheet
    Dim newRow As Long, newFileNum As Long
    Dim lastRow As Long, currentRow As Long
    Dim newFileMake As Boolean: newFileMake = True
    Dim currentStartRow As Long
    
    ' アクティブシートを指定
    Set ws = ThisWorkbook.ActiveSheet
    
    ' 最終行を取得
    lastRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
    
    ' 新しいファイルにコピーするための変数を初期化
    'newFileNum = 0
    
    ' データをコピー
    For currentRow = 2 To lastRow
        ' ファイルを新作
        If newFileMake Then         ' 新しいファイルの作成フラグ
            If Not newWb Is Nothing Then
                ' 保存して閉じる
                newWb.Close SaveChanges:=True
            End If
            
            newFileMake = False
            ' 新しいブックを作成
            Set newWb = Workbooks.Add
            Set newWs = ActiveSheet
            ' ヘッダー行をコピー
            ws.Rows(1).Copy Destination:=newWs.Rows(1)

            ' 新しいファイルを保存
            newFileNum = newFileNum + 1
            newWb.SaveAs ThisWorkbook.Path & "\" & newFileName & Format(newFileNum, "0") & ".xlsx"
            
            newRow = 2                      ' 新ファイルの行数
            currentStartRow = currentRow    ' コピー元先頭行
        End If
        
        ' 一つのファイルの最大行が1000行＋b列に入っている値が一つ上の行と違う場合は新しいファイルを作成
        ' 最後の行の時も実行
        If (newRow >= maxRows And ws.Cells(currentRow, 2).Value <> ws.Cells(currentRow + 1, 2).Value) _
                        Or currentRow = lastRow Then
            newFileMake = True      ' 新しいファイルの作成フラグ
            ' 複数行をコピー
            ws.Rows(currentStartRow & ":" & currentRow).Copy Destination:=newWs.Rows("2:" & newRow)
        End If
        newRow = newRow + 1     ' 新ファイルの行数
        
    Next currentRow
    
    ' 保存して閉じる
    newWb.Close SaveChanges:=True
    ' 完了メッセージ
    MsgBox newFileNum & "個のファイルを作成しました。"
End Sub

Set ws = ThisWorkbook.ActiveSheet

lastRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row

Set newWb = Workbooks.Add
Set newWs = ActiveSheet

ws.Rows(1).Copy Destination:=newWs.Rows(1)

newWb.SaveAs _
    ThisWorkbook.Path & "\" & _
    newFileName & _
    Format(newFileNum, "0") & _
    ".xlsx"

NewFile_1.xlsx
NewFile_2.xlsx
NewFile_3.xlsx

If (newRow >= maxRows And _
    ws.Cells(currentRow, 2).Value <> _
    ws.Cells(currentRow + 1, 2).Value) _
    Or currentRow = lastRow Then

A社
A社
A社
A社
A社
A社

newWb.Close SaveChanges:=True

NewFile_1.xlsx
NewFile_2.xlsx
NewFile_3.xlsx
NewFile_4.xlsx
NewFile_5.xlsx