ファイル分割

コード

Sub ファイル分割メイン()

'定義
Dim cnt As Integer                              '処理件数用
Dim rngList As Range, myRng As Range            'フィルタ用
Dim maxRows As Long, lastGyou As Long           'コピー範囲の最終行
Dim filterRetu As Integer, filterGyou As Long   'フィルタ条件列・行
Dim insStrMae As String, insStrUshiro As String 'ファイル名挿入文字列
Dim fileNo As String                            'ファイル名挿入文字列
Dim newWB As Workbook
Dim tgtFolder As String                         '出力先フォルダ

Call 前処理

'セットアップ（出力フォルダ・フィルタ条件列　等）
tgtFolder = フォルダ作成()
With ThisWorkbook.Sheets(menuSheet)
    .Range("F5").Value = tgtFolder
    .Hyperlinks.Add anchor:=Range("F5"), Address:=Range("F5").Value
    filterRetu = .Range("G8").Value
    filterGyou = .Range("G9").Value
    insStrMae = .Range("G10").Value
    insStrUshiro = .Range("G11").Value
End With

'分割条件リストのセットアップ
With ThisWorkbook.Sheets(listSheet)
    Set rngList = .Range(.Cells(2, 2), .Cells(2, 2).End(xlDown))
End With

'分割メイン処理
cnt = 0
For Each myRng In rngList
    Application.StatusBar = myRng & "ファイルを処理中"
    ThisWorkbook.Sheets(syoriSheet).Select

    Cells(filterGyou, 1).AutoFilter
    Cells(filterGyou, 1).AutoFilter field:=filterRetu, Criteria1:=myRng
    lastGyou = Cells(Rows().Count, filterRetu).End(xlUp).Row 'フィルタ条件列目の最終行を取得
    
    If lastGyou <= filterGyou Then GoTo nextRng     '絞り込みゼロのときスキップ
    
    Rows("1:" & lastGyou).Copy
    
    Set newWB = Workbooks.Add
    
    Range("A1").PasteSpecial Paste:=xlPasteFormats
    Range("A1").PasteSpecial Paste:=xlPasteValues
    
    fileNo = Format(NO取得(myRng), "00") '条件からNOを取得
    newWB.SaveAs fileName:=tgtFolder & insStrMae & fileNo & "_" & myRng & insStrUshiro & ".xlsx"
    newWB.Close
    cnt = cnt + 1
nextRng:

Next myRng

Call 後処理

Application.StatusBar = False
ThisWorkbook.Sheets(menuSheet).Select
MsgBox cnt & "件の処理が完了しました", vbInformation, "完了"
End Sub

解説

サンプルデータ出典