集計エクセルデータを「取引先」や「担当者」毎にエクセルを分けて保存したい時があります。
今回はVBAを使用して、エクセルデータを分割して別のエクセルワークブックに保存する方法を解説します。
目次
【マクロVBA】エクセルデータを分割して新しいワークブックに保存する
Sub SplitDataAndSave()
'C3セル「分割データ保存先」が空欄だった場合、vbaを終了する
If Range("C3").Value = "" Then
MsgBox "分割データ保存先情報を記入してください。"
Exit Sub
End If
'貼り付けシートの情報が空欄だった場合、vbaを終了する
If Worksheets("貼り付け").Range("A1").Value = "" Then
MsgBox "データを張り付けてください。"
Exit Sub
End If
Dim WB As Workbook
Set WB = ActiveWorkbook
'分割先データ保存先
Dim Path As String
Path = WB.Worksheets("要領").Range("C3") & "\"
Dim R_Data As Integer
R_Data = 2
Dim file_name As String
file_name = WB.Worksheets("要領").Range("C4")
'グループの件数
Dim Ko As Integer
'列数をカウントする
Dim column_count As Long
column_count = WB.Worksheets("貼り付け").Range("A1").CurrentRegion.Columns.Count
Application.ScreenUpdating = False
'A列が空白になるまで作業を続ける
Do Until WB.Worksheets("貼り付け").Cells(R_Data, "A") = ""
WB.Worksheets("貼り付け").Activate
Ko = WorksheetFunction.CountIf(Columns("A"), Cells(R_Data, "A"))
'項目行をコピーする
WB.Worksheets("貼り付け").Activate
WB.Worksheets("貼り付け").Range("A1").Resize(1, column_count).Copy
'新しいWBを立ち上げる
Workbooks.Add
Set WB_new = ActiveWorkbook
'項目行を新しいWBに張り付ける(列幅のみ貼り付け)
WB_new.Worksheets("sheet1").Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
'項目行を新しいWBに張り付ける(データ貼り付け)
WB_new.Worksheets("sheet1").Range("A1").PasteSpecial
'データをコピーして新しいWBに張り付ける
WB.Worksheets("貼り付け").Activate
Range(Cells(R_Data, "A"), Cells(R_Data + Ko - 1, column_count)).Copy
WB_new.Worksheets("sheet1").Range("A2").PasteSpecial
'名前を付けて新しいWBを保存
WB_new.SaveAs Filename:=Path & Range("A" & R_Data).Value & "_" & file_name & ".xlsx"
WB_new.Close
R_Data = R_Data + Ko
Loop
Application.ScreenUpdating = True
MsgBox "完了しました。"
End Sub
概要
このマクロは、A列=1列目に記載の要素毎にデータを分割し、新しいワークブックに保存していきます。
このようにA列に記載した要素毎にエクセルデータを分割していきます。
要領シート
「要領」と書かれたシートには、以下情報を記載します。
ポイント
・C3セルに分割したエクセルデータの保存場所を指定。
・C4セルで分割したエクセルデータの名称を記載
貼り付けシート
ポイント
・1行目に必ず項目を記入する。
・A列の要素は、事前に昇順or降順で並び替えをする
このマクロは、A列のグループ毎に分割していきます。
マクロの実行前に、必ずA列で「並び替え」してグループ毎に並べ変えて下さい。
(並び替えをしないと、要素毎に抽出されません)
マクロ実行結果
このような形でA列目の要素毎にデータを分割し、新しいエクセルデータに保管することができました。
コメント