Excelファイルを複数のファイルに分割する

2021年7月14日2023年7月2日

EXCELで作成した表を分割して複数のファイルに分けるサンプルアプリを紹介します。
今回紹介するサンプルアプリは表の中にデータとして持っている会社名をもとに、ファイルを会社別に分割するVBAです。
業務の中で、一つのファイルを部署ごとに分けて配布したり、取引会社ごとにファイルを分けてメールで送る時などいろいろな場面で活用できるサンプルコードです。
なお、今回はソートされたデータをファイル分割しましたが、ランダムに並んでいるデータをファイル分割する場合は以下のサイトをご覧ください。

　https://scodebank.com/?p=1193

メソッドの説明

分割ファイルを作成する際に新規にファイル（ブック）を作成して、最後にデータをコピーした後に分割したファイルを保存して閉じる必要があります。
その際に利用するメッソドを抜きだすと以下のようになります。
まず、 Workbooks コレクションの Add メソッドで新規ワークブックを作成します。
新規ワークブックを作成した後は、分割元のファイルをコピーして、「ThisWorkbook.SaveAs ファイル名を含めたファイルパス」 で分割したファイルを保存してCloseメソッドでファイルを閉じます。

　 '新規ブック作成
　　 Set Wb2 = Workbooks.Add

分割元のデータをコピーするコードを記述

　 '分割したファイルを保存して閉じる
　　Wb2.SaveAs Filename:=FileNam ' 同一フォルダに保存して閉じる
　　Wb2.Close
　’分割ファイルのブックを解放
　　Set Wb2 = Nothing

サンプルコードの処理内容

「Excelファイル分割」ボタンをクリックすると、表の内容が会社別のファイルに分割されます。

サンプルコード　　　コードの作成手順はこちら

Sub Export_ExcelFile()

　  '変数の定義
   　 Dim Wb2 As Workbook, FileNam As String
  　  Dim xPath As String
  　  Dim key As String
      Dim i As Integer
    
  　  Dim Sh1 As Worksheet
      Dim Sh2 As Worksheet

  　 'ワークシートを指定する
   　 Set Sh1 = ThisWorkbook.Worksheets("Sheet1")
    
   　 'データの始まり５行目を指定
   　 Dim start As Long
  　  start = 5
   
　   '出力先のパスを指定
 　   With ActiveWorkbook
  　     xPath = .Path & "\"  'ファイルが置いてあるフォルダからのパスを指定
　    End With
    
 　 '注文番号が空欄の位置までループ
 　 Do While Sh1.Cells(start, 2) <> ""

  　  Set Wb2 = Workbooks.Add  ' 新規ブック作成
 　   Set Sh2 = Wb2.Worksheets("Sheet1") '新規ブックのシートを指定

 　  'ファイル名に付ける日付を取得
 　   Dim strDate As String
  　  strDate = DateSerial(Year(Now), Month(Now), 1)
　    strDate = Format(strDate, "yyyymm")

  　 'Excelファイル出力
 　  FileNam = xPath & Sh1.Cells(start, 2).Value & "" & strDate & ".xlsx"

　  'タイトル欄を新規ブックのシートにコピー
 　  Sh1.Range(Sh1.Cells(4, 2), Sh1.Cells(4, 7)).Copy Sh2.Range("B2")
 
  　 '新規ブックの最初の貼り付け位置を指定（３行目から貼り付ける）
   　 i = 3
 　  'コピー元の最初の会社名を取得
   　 key = Sh1.Cells(start, 2).Value

  　 '同じ会社名が続く間はループ
  　  Do While Sh1.Cells(start, 2).Value = key
 
     　 'データ行コピー
     　 Sh1.Range(Sh1.Cells(start, 2), Sh1.Cells(start, 7)).Copy Sh2.Range("B" & i)

     　 i = i + 1            'コピー先の行を一つ下にずらす。
    　  start = start + 1    'コピー元の会社名行を一つ下にずらす。
    
   　 Loop
　
  　 '出力した表の最後に水平区線を引く
   　 Sh2.Range("B" & i & ":" & "G" & i).Borders(xlEdgeTop).LineStyle = xlContinuous
   　 Sh2.Range("B" & i & ":" & "G" & i).Borders(xlEdgeTop).Weight = xlThin

　  'コピー先の列幅をデータ長に合わせる
  　 Wb2.Worksheets("Sheet1").Range("B:G").Columns.AutoFit

 　 '分割したファイルを保存して閉じる
   　Wb2.SaveAs Filename:=FileNam  ' 同一フォルダに保存して閉じる
  　 Wb2.Close
　  '分割ファイルのブックを解放
  　 Set Wb2 = Nothing

　Loop

End Sub