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

2021年7月28日

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

メソッドの説明

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

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

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

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

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

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

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

Sub Export_ExcelFile()

   '変数の定義
     Dim Wb1 As Worksheet, 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")
    
     'データの始まり5行目を指定
     Dim start As Long
     start = 5
    
     Set Wb1 = ActiveSheet  '元シートをActiveSheetにセットする
    
    '出力先のパスを指定
     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")
 
    '新規ブックの最初の貼り付け位置を指定(3行目から貼り付ける)
     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