【Excel VBA】表の列の値毎に分割するには？(値がブックのファイル名)

Question

表を、ある列の値ごとにブックに分割するにはどうしたらよいですか？

具体的には、E列に「ABC店」「XYZ店」「asdf店」・・・のように15種類程度のパターンがあり、
「ABC店」の行だけ抽出して「ABC店.xlsx」というブックで保存したいです。
考え方的には、そのまま新ブックにコピーして不要行を削除、、、の繰り返しでしょうか？

一応、細かい表の仕様を書くと、
・106行×117列の横長な表です。
・1～3行目がヘッダー行、4行目が項目行なので、5行目以降のE列の値によって分割したい
・ヘッダー行、項目行は、全ファイルに入れたいです。
・表の中には数式が入っているセルがありますが、分割後はすべて値化したいです。
・106行目が合計行で「=SUBTOTAL(109,B5:B105)」等が複数列に入ってますが分割後も活かしたいです。
・分割後の列幅、行間等、レイアウトを崩さずに保ちたいです。
（印刷プレビューの設定も維持したままなんて可能でしょうか？）

詳しい方、よろしくお願いいたします。

goomania · Accepted Answer

ご質問者のご要望の中で、
>･･･分割後はすべて値化したいです。
というご要望は、とりあえず置いておいて以下のURLにあるVBAを使えば、分割そのものは、できそうな気がします。
https://mmm-program.com/vba-splitfile-copyfolder/
まず、上記のURLにあるVBAの５～10行目の設定を行います。
分割後のファイルの保存パス名、分割されるファイル名(VBAを記述するファイル名)、分割されるシート名を設定します。
ご質問者の説明では表の開始列が不明ですが、A列から表が始まっている(A列が空白列でない)なら、
dataCol = 2
を
dataCol = 1
さらに、ご質問者の説明だと、9行目
TargetCol = 2
を
TargetCol = 5
に修正すればよいのではないかと思います。
ただし、このURLにあるVBAは宣言文がかなり漏れています。
このため、頭に
Option Explicit
を記述するとエラーが出まくります。
修正する力がある方なら修正してから利用すべきですが、「Option Explict」を記述せず、設定をカスタマイズして実行するだけなら修正しなくても一応動作するようです。

Qchan1962 · Answer

＃６です。土日と芝刈りに出かけてまして　返信を見る事が出来ませんでした既に回答されている方もありますので恐縮ですが、、サンプルを書いた方が解らずとも研究材料となると思います。予てから問題は、列幅や罫線、マクロ登録オブジェクト、移したいマクロなどかなと思います。 ①データを作りテンプレシートに出力、新規ブックとして保存この場合、罫線以外はあらかじめ用意するとこでコピーされます。罫線に関しては、コピー時設定する事になりますが、種類、可変位置（位置を特定するキーワードなど）が必要になります。 ②元データをコピーして新規ブックとした後に加工する罫線の心配は少ないですが、マクロ登録オブジェクトが複数ある場合残したいマクロ登録用オブジェクトを指定して他を削除する必要があります。また、マクロについてそのシートにイベントが書かれている場合新規ブックにも引き継がれる事になりイベントの制御を考えなくてはなりません。共通の課題としては新規ブックで使いたいマクロがシートモジュールからの実行で不具合が出る内容の場合、この場合は、標準モジュールをインポートする方法やコード自体をモジュールに書いたりする必要があります。どちらもVBAで出来ますが、前者のあらかじめ元ファイルからエクスポートしておいてインポートするのが簡単です。（1，2行）先ほど帰ったばかりなので、十分な検証を行っていませんが ①②共にサンプル提示します要　office365　条件、一連の準備をしてください使いたいマクロ名は暫定　test　です　コード内の　. を消さないでくださいモジュール名、プロシージャ名は　. でつなげます。マクロ登録オブジェクトは暫定シェープ　"四角形: 角を丸くする 1" ①テンプレシートモジュールに使いたいプロシージャを記載罫線設定条件は考慮していません。（テンプレシートには設定可能ですがはみ出したりするかと、、） ②（tanapyondai様のロジック）マクロなどの懸念材料が払しょくできませんが取り敢えず新規ブックシート上の不要シェープと思われるものは削除します Sub Test1() 'テンプレシートを使う Dim aryKey As Variant Dim i As Long Dim tpName As String Dim dataSh As Worksheet, tmpSh As Worksheet Set dataSh = ActiveSheet Set tmpSh = Worksheets(1) tpName = tmpSh.Name Application.ScreenUpdating = False Application.DisplayAlerts = False With dataSh 'office365なら1行でユニークデータを作れる？すごい！5行目から最終行1つ手前まで aryKey = Application.Unique(.Range("E5", .Range("E" & Rows.Count).End(xlUp).Offset(-1)).Value) .AutoFilterMode = False 'テストは初めのキーだけで、全部なら　UBound(aryKey) For i = 1 To 1 'UBound(aryKey) '出力先の値をクリア tmpSh.Cells.ClearContents 'ちょっと回りくどく読みにくいかも、変数使う？ With .Range("A4").CurrentRegion Range("A4", .Cells(.Count)).AutoFilter Field:=5, Criteria1:=aryKey(i, 1) tmpSh.Range("A1").Resize(.SpecialCells(xlCellTypeVisible).Rows.Count, .SpecialCells(xlCellTypeVisible).Columns.Count).Value _ = .SpecialCells(xlCellTypeVisible).Value End With .AutoFilterMode = False .Range("E" & Rows.Count).End(xlUp).EntireRow.Copy _ tmpSh.Range("E" & Rows.Count).End(xlUp).Offset(1).EntireRow tmpSh.Name = aryKey(i, 1) & "_Data" 'シート名 tmpSh.Copy '出来上がったシートをブックとして出力 With ActiveWorkbook '新規ブック ' On Error Resume Next .Worksheets(1).Shapes("四角形: 角を丸くする 1").OnAction _ = .Name & "!" & .Worksheets(1).CodeName & ".test" .SaveAs ThisWorkbook.Path & "\" & aryKey(i, 1) & "_" & Format(Date, "yyyymmdd") & ".xlsm", 52 .Close End With dataSh.Activate Next i End With tmpSh.Name = tpName dataSh.AutoFilterMode = False Application.DisplayAlerts = False Application.ScreenUpdating = True End Sub 最終行の処理は常に表示するように書き直せば一度で出来ますね Sub Test2() 'コピー後　削除 Dim aryKey As Variant Dim i As Long Dim delRng As Range Dim mySH As Worksheet Dim shp As Shape Set mySH = Worksheets("実行シート名を明示") mySH.Activate Application.ScreenUpdating = False Application.DisplayAlerts = False 'office365なら1行でユニークデータを作れる？すごい！5行目から最終行1つ手前まで For Each aryKey In Application.Unique(mySH.Range("E5", mySH.Range("E" & Rows.Count).End(xlUp).Offset(-1))) mySH.Copy '新規ブック--- With ActiveWorkbook.Worksheets(1) For i = 5 To .Range("E" & Rows.Count).End(xlUp).Row - 1 If .Cells(i, "E").Value <> aryKey Then If delRng Is Nothing Then Set delRng = .Cells(i, "E") Else Set delRng = Union(delRng, .Cells(i, "E")) End If End If Next If Not delRng Is Nothing Then delRng.EntireRow.Delete ' On Error Resume Next 'Shapes("四角形: 角を丸くする 1")は暫定オブジェクト名 .Shapes("四角形: 角を丸くする 1").OnAction _ = ActiveWorkbook.Name & "!" & .CodeName & ".test" 'testはプロシージャ名 For Each shp In ActiveSheet.Shapes If shp.Name <> "四角形: 角を丸くする 1" And shp.Name <> "Rounded Rectangle 1" Then shp.Delete Next .SaveAs ThisWorkbook.Path & "\" & aryKey & "_" & Format(Date, "yyyymmdd") & ".xlsm", 52 ActiveWorkbook.Close End With Set delRng = Nothing Next aryKey Application.DisplayAlerts = False Application.ScreenUpdating = True End Sub

goomania · Answer

No.7です。

>ありがとうございます。今度はうまく行きました

お役に立てて良かったです。

>最下行の「Subtotal」が入っている合計の行まで無くなってしまうんです。
>これを残す、または付け足す事は可能でしょうか？

元のシートの最下行に「SUBTOTAL」があるとして、オリジナルのコードを無理やり修正するとすれば、

67行目の空行に

ws.Cells(ListLastRow, targetcol) = targetNum

同じく81行目の空行に

ws.Cells(ListLastRow, targetcol) = "店別合計"

を追記するという手はどうでしょう。
これがうまくいったら、次は

>複製されたブックの方は、処理したシート以外は全て削除できないでしょうか？

については、28行目と30行目の間に

'対象はアクティブなワークブック
    With ActiveWorkbook
'警告表示停止    
Application.DisplayAlerts = False
'全シートを検索       
 For Each ws In .Worksheets
            'ActiveSheet以外を削除
            If ws.Name <> .ActiveSheet.Name Then ws.Delete
        Next
'警告表示復活     
   Application.DisplayAlerts = True
    End With

を追記挿入してください。
これで、処理したシート以外は全て削除されるはずです。

ご健闘を祈ります。

goomania · Answer

No.4です、

>すごく完成に近づくソースだと思うのですが、不具合点がありました。
>確かに、E列に存在する値の数だけファイルが生成されたのですが、
>全て1行のみしか拾ってないのです。よって15ファイル共、同じファイル
>サイズです。例えば、「ABC店は」6行存在しますが、出来たファイル
>は1行のみです。

ということなので、何とか最小限の修正で前回回答でご案案内したVBAを活用できない検討してみました。
前回回答のVBAは作者の方の勘違いがあり、パラメータを変更しても、最終的にA列の値が分割グループになっていないと行データが削除されてしまうという不具合があるようです。
VBA掲載ページの最下部に利用された方がご質問されています。(作者の方は気づいていないようですが･･･)
これを回避するためには3箇所の修正が必要です。
掲載されているVBAの

28行目
Call CellsDeleteFast(dataRow, dataCol, Item)
を
Call CellsDeleteFast(dataRow, dataCol, targetcol, Item)
に修正

58行目
Sub CellsDeleteFast(dataRow, dataCol, targetNum)
を
Sub CellsDeleteFast(dataRow, dataCol, targetcol, targetNum)
に修正

71行目
If ws.Cells(i, dataCol) <> targetNum Then
を
If ws.Cells(i, targetcol) <> targetNum Then
に修正

以上の修正を加えたうえで、パラメータを調整してみてください。なお、分割のグループ分けの基準となる列(ご質問者の例ではE列)に空白があってはいけません。空白があるとその行は削除されてしまいます。

Qchan1962 · Answer

こんにちは
＞これなら印刷設定も罫線も考慮不要になりますよね？
見えていませんのでわかりませんが、多分良いと思います。
処理の強度は削除などで大きいかも知れませんけれど、確かに罫線の問題があるのでシート複製、不要データ削除の方が、、よいかな？

＞(相談)元のマクロには、不要な列を非表示化して見やすくするマクロボタンを設置しています。分割後もそれを活かせるでしょうか？

これに付いては、⑥の部分で行います。
新規ブックの保存時ですね。

コードを簡単にするため事前準備してください。
実行したいプロシージャを保存するシートモジュールに書いてください。
シートモジュールでないと参照設定などを加える必要が出て来ます。
この部分の参考コードです。

With ActiveWorkbook  '新規ブック
                ' On Error Resume Next
                Application.DisplayAlerts = False
                
                .Worksheets(1).Shapes("四角形: 角を丸くする 1").OnAction _
                        = .Name & "!" & .Worksheets(1).CodeName & ".test"
                        
                .SaveAs ThisWorkbook.Path & "\ファイル名_" & Format(Date, "yyyymmdd") & ".xlsm", 52
                .Close
                Application.DisplayAlerts = False
            End With

マクロ登録シェイプをShapes("四角形: 角を丸くする 1")と仮定
こんな感じでシートモジュールのマクロを登録できるかと、、。

Qchan1962 · Answer

こんばんは、
＞具体的には、E列に「ABC店」「XYZ店」「asdf店」・・・のように15種類程度のパターンがあり
これは、見出しと最終行の合計？を除くとこの15種類以外はないと言う事でしょうか？

無いのであれば、この行で重複しないリスト、、データを作りその配列、又はコレクションで同じ処理を繰り返せば良いと思います。

＞・106行×117列の横長な表です
これは、可変可能なので割愛

＞・1～3行目がヘッダー行、4行目が項目行なので、5行目以降のE列の値によって分割したい
CurrentRegionが成立するならば、4行目にフィルタをセットすれば抽出できると思います。
＞・ヘッダー行、項目行は、全ファイルに入れたいです。
上記のフィルタ設定で可視セルSpecialCells(xlCellTypeVisible)を項目行は見えているはずなので、大丈夫

＞・表の中には数式が入っているセルがありますが、分割後はすべて値化したいです。
xlPasteValuesを使うか、代入式を使うか、どちらも可能ですが後者ですかね

＞・106行目が合計行で「=SUBTOTAL(109,B5:B105)」等が複数列に入ってますが分割後も活かしたいです
相対参照で大丈夫なら、最終行を新規シートの最終行+1行にコピペすればOK?

＞・分割後の列幅、行間等、レイアウトを崩さずに保ちたいです。
うう、列幅はともかく行は現状どの様になっているか、ですね。
行の高さを最適化するだけで良ければ、簡単ですが、、

罫線などはあるのかな？、、取敢えず、準備を手作業で次のように
元表のあるシートのコピーを作り（VBAでこのシートをテンプレ代わりに使う、、、インデックス1（一番左）に移動
値をすべてDelete、不要な書式も変更、列幅、行の高さはそのままで
（見出しの書式はそのままが良いかも、、）

下準備をした方が多分処理も少なくなる？かな

＞（印刷プレビューの設定も維持したままなんて可能でしょうか？）

ご質問の範囲だと何ページもあると思いますね
何かポイントになるキーがあれば、それを基に設定する事は出来ますが
テンプレシートの複製だけで対応できるか、、
印刷範囲などは、プリンタードライバに依存しているのでプリンターが変わると変わる可能性もあるので、、不明です。

①下準備
テンプレシートを作る（書式設定などの為）
新規ブックを保存するフォルダを作成

②「ABC店」「XYZ店」「asdf店」・・・のように　一意のリスト（配列、コレクションなど）を作る　この値で繰り返す

③フィルタを４行目にかけ②のキーで抽出
（見出しは見える、合計行は見えない）

④抽出部分をWorksheets(1)セルクリアー後、Worksheets(1)セルに代入

⑤フィルタを解除して最終行をコピーしWorksheets(1)最終行+1行に貼り付け

⑥Worksheets(1)をコピー
ActiveWorkbookを名前を付けて保存

繰り返し③へ

長文申し訳ないです。少し難しいでしょうか？
デモデータが無いけれど、ちょっと試してみようかな、、

mygoonickname · Answer

No.1の者です。

> 不要行を削除すると、106行の関数：=SUBTOTAL(109,B5:B105)　
> の位置も変わり、参照している範囲も変わる様な気がしますが。
>実験してみました。絶対参照をしていないので、途中の行を削除しても参照>範囲もちゃんと付いてきます。
→失礼しました。削除は大丈夫ですが、コピーするとダメですね。

＞全種類くまなく処理するというのが分かりません。
15種類程度のパターンの取得方法が不明という事でしょうか？
検索しただけですが、下記が参考になるでしょうか？

【VBA】重複しないリストを抽出【AdvancedFilterが便利】
https://daitaideit.com/vba-advancedfilter/

mygoonickname · Answer

こんばんは。

不要行を削除すると、106行の関数：=SUBTOTAL(109,B5:B105)　の位置
も変わり、参照している範囲も変わる様な気がしますが。
最期に、VBAで、関数を入れ直す？

レイアウトを維持したままとなると、ブック自体を複製した方が、簡単な
様な気がしますね。　ブック①を複製し、5行目以降をクリアする。・・・②
（①：原本、②：複製したブック）
①のデータが入っているブックで、E列にフィルターを掛けてABC店を抽出。
抽出したデータをコピーして、②へ値として貼り付け。
=SUBTOTAL(109,　～　)　が必要なら、式を入れる。
名前を付けて保存で、ABC店.xlsxとする。

②の5行目以降をクリアする。
フィルターで、次の条件を抽出　　これを繰り返すでしょうか？

ファイルをコピーする
https://www.moug.net/tech/exvba/0060075.html

fujillin · Answer

こんばんは

どちらでも同じようなものですけれど・・・

＞そのまま新ブックにコピーして不要行を削除、、、
＞の繰り返しでしょうか？
フィルターを掛けてコピペの方が、感覚的には少し楽かも。
セルに数式が入っているようなので、コピペや削除をしても問題ないのかはわかりませんけれど…

【Excel VBA】表の列の値毎に分割するには？(値がブックのファイル名)

ご質問者のご要望の中で、

＃６です。

No.7です。

No.4です、

こんにちは

こんばんは、

No.1の者です。

こんばんは。

こんばんは

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング