プロが教えるわが家の防犯対策術!

表を、ある列の値ごとにブックに分割するにはどうしたらよいですか?

具体的には、E列に「ABC店」「XYZ店」「asdf店」・・・のように15種類程度のパターンがあり、
「ABC店」の行だけ抽出して「ABC店.xlsx」というブックで保存したいです。
考え方的には、そのまま新ブックにコピーして不要行を削除、、、の繰り返しでしょうか?

一応、細かい表の仕様を書くと、
・106行×117列の横長な表です。
・1~3行目がヘッダー行、4行目が項目行なので、5行目以降のE列の値によって分割したい
・ヘッダー行、項目行は、全ファイルに入れたいです。
・表の中には数式が入っているセルがありますが、分割後はすべて値化したいです。
・106行目が合計行で「=SUBTOTAL(109,B5:B105)」等が複数列に入ってますが分割後も活かしたいです。
・分割後の列幅、行間等、レイアウトを崩さずに保ちたいです。
(印刷プレビューの設定も維持したままなんて可能でしょうか?)

詳しい方、よろしくお願いいたします。

質問者からの補足コメント

  • HAPPY

    Qchan1962様
    私の説明不足の部分を補足します。

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

    はい。ただし増減の可能性があるので15種類程度と書きました。
    例えばE4には「店舗名」という項目名、5行目以降には全店舗五月雨に追記されるようになっています。
    でも店舗毎に担当者がいて、自分の担当店舗だけ見たいのです。ソートするとかオートフィルタで自分の店舗だけ見る事は可能なのですが、独立のブックとして切り出して、各自の加工をしていきたいというリクエストがあり、それに応えるのが私なのです・・・
    なので仰るロジックに異論はありません。
    行数、列数、ほぼ固定ですが、将来変更になる可能性はありますが、何ら問題ないと思ってます。

    No.5の回答に寄せられた補足コメントです。 補足日時:2021/11/18 19:28
  • どう思う?

    Qchan1962様からの回答に捕捉します。
    ・表内の関数は水平に参照してるだけなので値にせずそのままが良いですし、Subtotalは活かしたいです。
    ・印刷設定は考慮しなくて良い事が判明しました。ユーザが自由に設定します。
    ・罫線は引いてあります。
    ・空行は不要なので結果の行数は十数行に減ります。

    素人なりのロジックは、
    まず、丸々シート全体を複製し、オートフィルタで「ABC店」以外の行だけ削除して、フィルタを解除すれば「ABC店」だけ残ります。(空行も一掃する)
    それを「ABC店_yyyymmdd.xlsx」で元のマクロブック本体と同じフォルダ内に保存する。
    これなら印刷設定も罫線も考慮不要になりますよね?

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

      補足日時:2021/11/18 21:07

A 回答 (9件)

こんばんは



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

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

こんばんは。



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

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

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

ファイルをコピーする
https://www.moug.net/tech/exvba/0060075.html
    • good
    • 0
この回答へのお礼

> 不要行を削除すると、106行の関数:=SUBTOTAL(109,B5:B105) 
> の位置も変わり、参照している範囲も変わる様な気がしますが。

実験してみました。絶対参照をしていないので、途中の行を削除しても参照範囲もちゃんと付いてきます。

ABCだけについて処理するなら分かりますが、全種類くまなく処理するというのが分かりません。

お礼日時:2021/11/16 23:07

No.1の者です。



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

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

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

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


>・・・分割後はすべて値化したいです。
というご要望は、とりあえず置いておいて以下のURLにあるVBAを使えば、分割そのものは、できそうな気がします。
https://mmm-program.com/vba-splitfile-copyfolder/
まず、上記のURLにあるVBAの5~10行目の設定を行います。
分割後のファイルの保存パス名、分割されるファイル名(VBAを記述するファイル名)、分割されるシート名を設定します。
ご質問者の説明では表の開始列が不明ですが、A列から表が始まっている(A列が空白列でない)なら、
dataCol = 2

dataCol = 1
さらに、ご質問者の説明だと、9行目
TargetCol = 2

TargetCol = 5
に修正すればよいのではないかと思います。
ただし、このURLにあるVBAは宣言文がかなり漏れています。
このため、頭に
Option Explicit
を記述するとエラーが出まくります。
修正する力がある方なら修正してから利用すべきですが、「Option Explict」を記述せず、設定をカスタマイズして実行するだけなら修正しなくても一応動作するようです。
    • good
    • 1
この回答へのお礼

ありがとうございます。
すごく完成に近づくソースだと思うのですが、不具合点がありました。
確かに、E列に存在する値の数だけファイルが生成されたのですが、全て1行のみしか拾ってないのです。よって15ファイル共、同じファイルサイズです。
例えば、「ABC店は」6行存在しますが、出来たファイルは1行のみです。
もちろんパラメータを色々いじって試したけど、うまく行きませんでした。
あと最終行のSubtotal行が消されてしまうのも何とかしないといけません。
もっと読み込んでカスタマイズしないといけないようです。

お礼日時:2021/11/18 21:59

こんばんは、


>具体的には、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店」・・・のように 一意のリスト(配列、コレクションなど)を作る この値で繰り返す

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

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

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

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

繰り返し③へ

長文申し訳ないです。少し難しいでしょうか?
デモデータが無いけれど、ちょっと試してみようかな、、
この回答への補足あり
    • good
    • 1

こんにちは


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

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

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


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

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")と仮定
こんな感じでシートモジュールのマクロを登録できるかと、、。
    • good
    • 0
この回答へのお礼

ありがとうございます。
しかしよく理解できてないかもしれません。

とりあえずやったのは、
・新規Bookでマクロの記録で適当な操作を記録しました。
・それはModule1に記録されますが、そのソースをSheet1(Sheet1)のソースにコピペし、Module1は解放
・Sheet1(Sheet1)のソースのEnd Subの直前に、頂いた上記のソースを貼りました。
・そして四角の図形オートシェイプをシートにおいて、右クリック→マクロの登録で、「Sheet1.Macro1」を割り当てました。

こんな具合です。
そこで、図形をクリックしたところ、適当な操作が再現された後、エクセル終了。
同じ場所に、同じファイル名_yyyymmdd.xlsm が作成されてるのを確認。
そのファイルを開くと、オリジナルの新規Bookと同じ内容でした。

意図が汲み取れてなかったらすみません(^^;

お礼日時:2021/11/20 00:20

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列)に空白があってはいけません。空白があるとその行は削除されてしまいます。
    • good
    • 0
この回答へのお礼

ありがとうございます。今度はうまく行きました!すごいですね!
後の為に補足します。パラメータの部分です。

dataRow = 5 '分割したいデータの始点行を指定

とありますが、
今回の場合、
「1~3行目がヘッダー行、4行目が項目行、5行目以降がデータ」なので
「dataRow = 5」と誤解してしまいましたが、「dataRow = 4」とするのが正しいようです。
「分割したいデータの始点行」とは項目行も含めた始点行の事でした。
私は誤解してたので念のため書いておきます。

今回のプログラムほぼ完ぺきなのですが、2つ相談があります。
当然なのですが、最下行の「Subtotal」が入っている合計の行まで無くなってしまうんです。
これを残す、または付け足す事は可能でしょうか?
具体的には、106行目が合計行です。
「=SUBTOTAL(109,Z5:Z105)」という関数が、
Z~AE列、AU~AZ列、BP~BU列、CK~CP列、DF~DK列の中に入ってます。

もう一つは、複製されたブックの方は、処理したシート以外は全て削除できないでしょうか?
元のブックには全部で5シートあるのですが、生成した15ファイルに全て残ります。
担当者に「悪いけど他のシートは削除してね」と伝えれば済む話ですがそこまで出来たら嬉しいなというだけです。
長くなってすみません。
可能なら教えてください。

お礼日時:2021/11/20 11:00

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

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

ご健闘を祈ります。
    • good
    • 0
この回答へのお礼

ありがとうございます。
変更したい要望に簡単に合わせられちゃうのってすごいですね!

更に手を加えた箇所を残しておきます。

> 同じく81行目の空行に
> ws.Cells(ListLastRow, targetcol) = "店別合計"

ws.Cells(ListLastRow, targetcol) = "店別合計"
だと、E列の最下行に"店別合計"が入ってしまいます。
A列の最下行に「合計」という文字が入っているのでE列には不要です。
試しにこの行を削除してみたら、最下行に店舗名が入ってしまいました。
なので、
ws.Cells(ListLastRow, targetcol) = "" としたら解決しました。
(応急処置かもしれませんが、自分で出来る対処として。。。)

また、ファイルを保存する直前に以下の行を加えて、切り分けたブックのシート名が店舗名になるようにしてみました。
Worksheets(targetSheet).Name = Item

ほぼ完璧です!
ありがとうございました。

お礼日時:2021/11/22 10:00

#6です。


土日と芝刈りに出かけてまして 返信を見る事が出来ませんでした

既に回答されている方もありますので恐縮ですが、、
サンプルを書いた方が解らずとも研究材料となると思います。

予てから問題は、列幅や罫線、マクロ登録オブジェクト、移したいマクロ
などかなと思います。

①データを作りテンプレシートに出力、新規ブックとして保存
この場合、罫線以外はあらかじめ用意するとこでコピーされます。
罫線に関しては、コピー時設定する事になりますが、種類、可変位置(位置を特定するキーワードなど)が必要になります。

②元データをコピーして新規ブックとした後に加工する
罫線の心配は少ないですが、マクロ登録オブジェクトが複数ある場合
残したいマクロ登録用オブジェクトを指定して他を削除する必要があります。
また、マクロについてそのシートにイベントが書かれている場合
新規ブックにも引き継がれる事になりイベントの制御を考えなくてはなりません。

共通の課題としては新規ブックで使いたいマクロがシートモジュールからの実行で不具合が出る内容の場合、この場合は、標準モジュールをインポートする方法やコード自体をモジュールに書いたりする必要があります。
どちらも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
    • good
    • 0
この回答へのお礼

ありがとうございます!
こちらもテストしてみて、応用したいと思います。

お礼日時:2021/11/22 22:44

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!


このQ&Aを見た人がよく見るQ&A