大量データのExcelファイルを行数で任意のファイル数に分割するVBA

Attribute VB_Name = "SplitExcelFile"
Option Explicit

Sub SplitExcelFile()
    
    Dim wbSource As Workbook
    Dim wsSource As Worksheet
    Dim wbNew As Workbook
    Dim wsNew As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim dataRows As Long
    Dim rowsPerFile As Long, remainderRows As Long
    Dim startRow As Long, endRow As Long
    Dim sourcePath As String, fileName As String, filePath As String
    Dim rngHeader As Range, rngData As Range
    Dim splitCount As Variant
    Dim i As Integer
    Dim confirmMsg As String
    
    ' ===== ファイル選択ダイアログ =====
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "分割するExcelファイルを選択してください"
        .Filters.Clear
        .Filters.Add "Excelファイル", "*.xlsx; *.xlsm; *.xls; *.xlsb"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath & "\"
        
        If .Show = False Then
            MsgBox "キャンセルされました。", vbInformation
            Exit Sub
        End If
        
        filePath = .SelectedItems(1)
    End With
    
    ' ===== 分割数の入力 =====
    Do
        splitCount = Application.InputBox( _
            Prompt:="分割数を入力してください（2～100）", _
            Title:="分割数の指定", _
            Default:=2, _
            Type:=1)  ' 1 = 数値のみ
        
        ' キャンセルされた場合
        If splitCount = False Then
            MsgBox "キャンセルされました。", vbInformation
            Exit Sub
        End If
        
        ' 入力値の検証
        If splitCount >= 2 And splitCount <= 100 And splitCount = Int(splitCount) Then
            Exit Do
        Else
            MsgBox "2～100の整数を入力してください。", vbExclamation
        End If
    Loop
    
    ' パフォーマンス向上のための設定
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    
    On Error GoTo ErrorHandler
    
    ' ===== 対象ファイルを開く =====
    Application.StatusBar = "ファイルを読み込み中..."
    Set wbSource = Workbooks.Open(filePath, ReadOnly:=True)
    Set wsSource = wbSource.Sheets(1)
    
    ' パス・ファイル名を取得
    sourcePath = wbSource.Path & "\"
    fileName = Left(wbSource.Name, InStrRev(wbSource.Name, ".") - 1)
    
    ' 最終行・最終列を取得
    lastRow = wsSource.Cells(wsSource.Rows.Count, 1).End(xlUp).Row
    lastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
    
    ' データ行数（ヘッダー除く）
    dataRows = lastRow - 1
    
    ' データが少ない場合は終了
    If dataRows < splitCount Then
        MsgBox "データ行数（" & dataRows & "行）が分割数（" & splitCount & "）より少ないため、分割できません。", vbExclamation
        wbSource.Close False
        GoTo CleanUp
    End If
    
    ' 各ファイルの行数を計算
    rowsPerFile = Int(dataRows / splitCount)
    remainderRows = dataRows Mod splitCount
    
    ' 確認メッセージを作成
    confirmMsg = "以下の内容で分割します。よろしいですか？" & vbCrLf & vbCrLf & _
                 "対象ファイル: " & wbSource.Name & vbCrLf & _
                 "総データ行数: " & Format(dataRows, "#,##0") & " 行" & vbCrLf & _
                 "分割数: " & splitCount & " ファイル" & vbCrLf & vbCrLf & _
                 "【分割内訳】" & vbCrLf
    
    For i = 1 To splitCount
        If i <= remainderRows Then
            confirmMsg = confirmMsg & "  Part" & i & ": ヘッダー + " & Format(rowsPerFile + 1, "#,##0") & " 行" & vbCrLf
        Else
            confirmMsg = confirmMsg & "  Part" & i & ": ヘッダー + " & Format(rowsPerFile, "#,##0") & " 行" & vbCrLf
        End If
        ' 表示が長くなりすぎる場合は省略
        If i >= 10 And i < splitCount Then
            confirmMsg = confirmMsg & "  ..." & vbCrLf
            Exit For
        End If
    Next i
    
    confirmMsg = confirmMsg & vbCrLf & "保存先: " & sourcePath
    
    If MsgBox(confirmMsg, vbYesNo + vbQuestion, "確認") = vbNo Then
        wbSource.Close False
        GoTo CleanUp
    End If
    
    ' ヘッダー範囲を取得
    Set rngHeader = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(1, lastCol))
    
    ' ===== 分割ファイルの作成 =====
    startRow = 2  ' データ開始行（ヘッダーの次）
    
    For i = 1 To splitCount
        Application.StatusBar = "ファイル " & i & " / " & splitCount & " を作成中..."
        
        ' このファイルの行数を計算（余りを前のファイルに分配）
        If i <= remainderRows Then
            endRow = startRow + rowsPerFile
        Else
            endRow = startRow + rowsPerFile - 1
        End If
        
        ' 新しいブックを作成
        Set wbNew = Workbooks.Add(xlWBATWorksheet)
        Set wsNew = wbNew.Sheets(1)
        
        ' シート名を設定（エラー回避）
        On Error Resume Next
        wsNew.Name = wsSource.Name
        On Error GoTo ErrorHandler
        
        ' ヘッダーをコピー
        rngHeader.Copy wsNew.Range("A1")
        
        ' データをコピー
        Set rngData = wsSource.Range(wsSource.Cells(startRow, 1), wsSource.Cells(endRow, lastCol))
        rngData.Copy wsNew.Range("A2")
        
        ' ファイルを保存
        wbNew.SaveAs sourcePath & fileName & "_Part" & i & ".xlsx", xlOpenXMLWorkbook
        wbNew.Close False
        
        ' 次のファイルの開始行を設定
        startRow = endRow + 1
    Next i
    
    ' 元ファイルを閉じる
    wbSource.Close False
    
    ' 完了メッセージ
    MsgBox "分割が完了しました！" & vbCrLf & vbCrLf & _
           "作成ファイル: " & splitCount & " 個" & vbCrLf & _
           "  " & fileName & "_Part1.xlsx ～ " & fileName & "_Part" & splitCount & ".xlsx" & vbCrLf & vbCrLf & _
           "保存先: " & sourcePath, vbInformation, "完了"
    
CleanUp:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    Application.StatusBar = False
    Exit Sub
    
ErrorHandler:
    MsgBox "エラーが発生しました: " & Err.Description, vbCritical
    
    On Error Resume Next
    If Not wbNew Is Nothing Then wbNew.Close False
    If Not wbSource Is Nothing Then wbSource.Close False
    On Error GoTo 0
    
    Resume CleanUp
    
End Sub