ヘルプの森~Excel・Access・Office全般ヘルプデスクサイト

No.010

ソートしたグループごとのデータを別ブックに分割するサンプルVBA

2003/2007/2010/2013/2016

以前お仕事で、こんな面倒な作業が一時期毎日ありました。

毎日ダウンロードした進捗データを、グループ(そのときは部署)ごとに配布するため、グループごとのデータに分割する、といったものです。
つまり、大きなデータをソートし、グループごとに分割したブックを作成する、ということで、グループの個数分ブックを作ることになります。
グループが数個であれば毎日手作業もなんとかがんばれると思いますが、そのときのグループ数は数十個あり、これはもう速攻で、マクロを作りました。

今回は、そのときに利用したマクロに手を加え、汎用的に利用できるサンプルを作りました。

グループ分割サンプルイメージ

上図のように、左の元データでソートしてある[列1]のグループごとに、グループ名のファイルを作成します。

サンプルVBAファイル ダウンロード

すぐ上のリンクをクリックし、ファイルをダウンロードしてご利用ください。

設定して実行ボタン

では、少し説明いたします。

ダウンロードいただいたブックの「★設定8項目」とある必要事項を入力設定し、対象の分割元のブックを一緒に開いて、ボタンをクリックして実行します。

VBAが行う操作概要は、グループごとのデータをコピーして新規ブックに貼り付け、新規ブックにグループの名前を付けて保存をする、という処理を繰り返し、データがある分実施します。分割元ブックはいじりません。
VBAの記述としては、Do~Loopの構文をのほかは、コピー/貼り付け/ブック保存ですので、コードとしては素朴な構造となっています。

最後に一応記述を記しておきます。

Sub Sample()

  Dim MacroB As Worksheet  'このブックのシート
  Dim Wb_Data As Workbook  '1. 分割元ブック
  Dim Wb_new As Workbook  '分割データ保存ブック
  Dim Ws As String  '2. 分割元シート名
  Dim Path As String  '3. 分割データ保存先
  Dim C_Group As String  '4. グループ対象列
  Dim C_Copy As String  '5. コピーデータ右端列
  Dim YMD As String  '6. 保存ブック日付の表示形式
  Dim PSW As String  '7. 読み取りパスワード
  Dim R_Data As Integer  'データの行番号
  Dim Ko As Integer  'グループの件数

  Set MacroB = Workbooks("ex100010.xlsm").Worksheets(1)  'このブックのシート
  Set Wb_Data = Workbooks(MacroB.Range("C11").Value)  '分割元のブック名
  Ws = MacroB.Range("C12")
  Path = MacroB.Range("C13") & "¥"
  C_Group = MacroB.Range("C14")
  C_Copy = MacroB.Range("C15")
  YMD = MacroB.Range("C16")
  PSW = MacroB.Range("C17")

  If YMD = "" Then
    YMD = ""
  Else
    YMD = Format(Date, YMD)
  End If

  R_Data = 2 'データの開始行

  Application.ScreenUpdating = False

  Do
    Wb_Data.Activate
    Worksheets(Ws).Range(Cells(1, 1), Cells(1, C_Copy)).Copy  '1行目の項目名コピー
    Workbooks.Add
    ActiveSheet.Paste Range("A1")  '新規ブックに貼り付け
    Set Wb_new = ActiveWorkbook

    Wb_Data.Activate
    Ko = WorksheetFunction.CountIf(Columns(C_Group), Cells(R_Data, C_Group)) 'グループの件数を算出
    Range(Cells(R_Data, "A"), Cells(R_Data + Ko - 1, C_Copy)).Copy  'グループ件数分コピー
    Wb_new.Activate
    ActiveSheet.Paste Range("A2")  '新規ブック項目の下に貼り付け
    Wb_new.SaveAs Filename:=Path & Cells(2, C_Group) & YMD & ".xlsx", _
    Password:=PSW  '指定したフォルダーに保存
    Wb_new.Close

    R_Data = R_Data + Ko

    Loop While Cells(R_Data, C_Group) <> ""
  MsgBox "完了!"

  Application.ScreenUpdating = True

End Sub

twitter hatena line pocket

関連ヘルプ

ブック内のすべてのワークシートで同じ処理を行う 《For Each~Next》
ブックを開くとき、閉じるときにマクロを自動実行したい 《イベント プロシージャ》
データを快速で検索するには 《Find》
アプリケーションを起動し動作させる 《Shell・SendKeys・Wait》
エラーの種類、そしてエラー処理の設置方法について 《On Error GoTo》
InputBox のテキスト ボックス入力時に日本語入力をオンにする 《SendKeys》
Excelのデータをテキスト ファイルに書き出す(出力する) 《Open・Print・Close》
ExcelからOutlookでメールを作成・送信する基本のVBA 《CreateObject関数》
Excelのメールアドレス データを使用し、Outlookのメールを自動送信する 《CreateObject関数》
右クリック、印刷、上書き保存などブックに規制をかける 《イベント プロシージャ Cancel=True》
フォルダー内のすべてブックを開いて同じ処理を行う 《Do~Loop・Dir》
フォルダー内のすべての画像ファイルをペイントで開きサイズ変更
フォルダー内のフォルダーとファイルの一覧をセルに書き出す1 《Dir》
フォルダー内のフォルダーとファイルの一覧をセルに書き出す2 《FileSystemObject》
フォルダー内のファイル名を変更する 《Do~Loop・Dir・Name~As》
ColorプロパティとRGB関数について、Color値からRGB、RGBからColor値を求める方法 《Color・RGB関数》