No.010
ソートしたグループごとのデータを別ブックに分割するサンプルVBA
2003/2007/2010/2013/2016
以前お仕事で、こんな面倒な作業が一時期毎日ありました。
毎日ダウンロードした進捗データを、グループ（そのときは部署）ごとに配布するため、グループごとのデータに分割する、といったものです。
つまり、大きなデータをソートし、グループごとに分割したブックを作成する、ということで、グループの個数分ブックを作ることになります。
グループが数個であれば毎日手作業もなんとかがんばれると思いますが、そのときのグループ数は数十個あり、これはもう速攻で、マクロを作りました。
今回は、そのときに利用したマクロに手を加え、汎用的に利用できるサンプルを作りました。
上図のように、左の元データでソートしてある［列1］のグループごとに、グループ名のファイルを作成します。
すぐ上のリンクをクリックし、ファイルをダウンロードしてご利用ください。
では、少し説明いたします。
ダウンロードいただいたブックの「★設定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
