『マクロで各シートの表を条件に沿ってファイルを分割したい』(ぽぽ)
表題の件、教えてください。
マクロが入っている「設定」シートのA2セルに記載しているファイルに対して、下記処理を実施したいです。
複数シートにフォームの同じ表があり、「まとめ」シート以外の全シートが対象で、A列の「名前」ごとに書式を保持したままファイルを分割したいです。
分割したファイルを保存するフォルダパスは、マクロが入っている「設定」シートのA1セルに記載しています。
イメージは、1行目の項目行は固定で、名前がaさんなら、aさんだけの表にして、指定フォルダにファイルを分割して保存したいです。何列目まであるかは分からないので、表全体を残す感じにしたいです。
分割したファイル名は、aさんなら、「aさん_まとめ.xlsx」としたい。
例えば、aさんが1つのシートにしか存在しない場合がありますが、その場合は該当がないシートには項目行だけ表示させて、aさんのファイルも生成するようにしたいです。(つまり、どこかのシートに存在する名前全て重複除いてファイル生成したいです)
イメージです。 A1セルから表が始まっており、これが複数シートあります。
名前 項目1 項目2 項目3
aさん 1 a aa
aさん 2 b bb
bさん 3 c cc
cさん 4 d dd
cさん 5 e ee
< 使用 Excel:Microsoft365、使用 OS:Windows10 >
|[A] |[B] |[C] |[D] [1]|名前 |項目1|項目2|項目3 [2]|aさん| 1|a |aa [3]|aさん| 2|b |bb [4]|bさん| 3|c |cc [5]|cさん| 4|d |dd [6]|cさん| 5|e |ee
整理のお手伝いだけども。。。^^
0.指定のブック開く
1.全シート読み込んで名前マスタ作成
2.マスタをキーに名前を加工して、名前を変えて保存
3.保存先のブックで当該シートをマスタでフイルタしたものに置き換え
4.全シート3.の処理して保存
5.2〜4全マスタ分繰り返す
6.後始末して御終い
いろいろ。。。様々な方法が有るとはぞんじますが↑
みたいなことでも出来るかもしれませんですね( ̄▽ ̄) ←かなりいいかげん^^;
m(__)m
(隠居Z) 2024/04/13(土) 10:48:02
うまくいかないのは3点です。(もっと違うやり方で良い方法あれば教えて頂けると勉強になります)
1.フィルタ掛かった状態で保存されていますが、不要なデータは削除して必要な名前の人のみ残したい。
2.例えばaさんは1つのシートしか該当ない場合もシート作成して項目名だけ残したいのですが、このコードだと名前が登場するシートのみしか生成されません。
3.マクロを再度稼働したときに毎回既にファイルがいますとメッセージでてしまうので、上書きするような設定にしたい。
Sub 分割()
Dim 分割元 As Workbook Dim folderPath As String Dim i As Long Dim ws As Worksheet Dim MyDic As Object Dim tmp As Variant Dim newWb As Workbook Dim wsIndex As Long
Set MyDic = CreateObject("Scripting.Dictionary")
' 分割元のファイルを読み取り専用で開く Set 分割元 = Workbooks.Open(Filename:=ThisWorkbook.Sheets("設定").Range("A2").Value, ReadOnly:=True) ' フォルダパスを取得 folderPath = ThisWorkbook.Sheets("設定").Range("A1").Value
Application.ScreenUpdating = False
' 名前の一覧を取得 For Each ws In 分割元.Sheets If ws.name <> "まとめ" Then For i = 2 To ws.Cells(ws.Rows.Count, "A").End(xlUp).Row If Not MyDic.Exists(ws.Cells(i, 1).Value) Then MyDic.Add ws.Cells(i, "A").Value, "" Next i End If Next ws
' 各名前ごとにファイルを作成 For Each tmp In MyDic.keys Set newWb = Workbooks.Add wsIndex = 1 For Each ws In 分割元.Sheets If ws.name <> "まとめ" Then ws.AutoFilterMode = False ws.Range("A1").AutoFilter Field:=1, Criteria1:=tmp If Application.WorksheetFunction.Subtotal(103, ws.Columns(1)) > 1 Then ws.Copy After:=newWb.Sheets(wsIndex) wsIndex = wsIndex + 1 End If End If Next ws ' 新しいブックの保存 newWb.SaveAs folderPath & "\" & tmp & "_まとめ.xlsx" newWb.Close SaveChanges:=True Next tmp
' 分割元のファイルを閉じる 分割元.Close SaveChanges:=False
Application.ScreenUpdating = True End Sub (ぽぽ) 2024/04/13(土) 18:16:54
>3.マクロを再度稼働したときに毎回既にファイルがいますとメッセージでてしまうので、上書きするような設定にしたい。
については、下記のように最初にフォルダを削除する方法で解決いたしました。
' 既存のファイルがあれば削除する On Error Resume Next Kill folderPath & "\" & "*.xlsx" On Error GoTo 0
下記2点については、色々やってみるもどうしても上手くいきませんので、引き続きアドバイス頂けますと助かります。よろしくお願いいたします。
1.フィルタ掛かった状態で保存されていますが、不要なデータは削除して必要な名前の人のみ残したい。
2.例えばaさんは1つのシートしか該当ない場合もシート作成して項目名だけ残したいのですが、このコードだと名前が登場するシートのみしか生成されません。
(ぽぽ) 2024/04/14(日) 07:14:40
横入失礼。 | 1.フィルタ掛かった状態で保存されていますが、不要なデータは削除して必要な名前の人のみ残したい。
ws.Copy After:=newWb.Sheets(wsIndex) これはシートコピーなので、不要データもそのままコピーされますよね。
そうではなく、セル範囲をコピーするようにしてください。 フィルタを掛ける前に、見出しを除くデータ部分のセル範囲を求めておき、 フィルタを掛けた後で、その範囲を普通にコピーペイストすれば、 フィルタが掛かったデータだけがコピーされる仕様ですので、これを利用します。
| 2.例えばaさんは1つのシートしか該当ない場合もシート作成して項目名だけ残したいのですが、 | このコードだと名前が登場するシートのみしか生成されません。 どのかたも、元のブックのシートの数と同じだけのシートが必要なんですか? ひとつのシートに、コピーペイストして、特定列に元のシート名を書き込む、という方法のほうがよいかも知れませんね。
いやそんなことじゃないです、というなら ・予め、(見出しを入れた)必要なシート数があるブックをテンプレートとして用意し、 それを増殖して個人個人別ブックを作り、 ・それにペイストしていくような作りにしたらいかがですか?
| 3.マクロを再度稼働したときに毎回既にファイルがいますとメッセージでてしまうので、 | 上書きするような設定にしたい。
Application.DisplayAlerts = False (保存処理) Application.DisplayAlerts = True と言う方法もあります。 (xyz) 2024/04/14(日) 08:06:48
>どのかたも、元のブックのシートの数と同じだけのシートが必要なんですか?
Yesです。
> ws.Copy After:=newWb.Sheets(wsIndex)
これはシートコピーなので、不要データもそのままコピーされますよね → そういうことだったのですね、、、
フィルタを掛ける前に、見出しを除くデータ部分のセル範囲を求めておき、 フィルタを掛けた後で、その範囲を普通にコピーペイストすれば、 フィルタが掛かったデータだけがコピーされる仕様ですので、これを利用します。 という指定の方法が分からないのですが、具体的に教えていただけますでしょうか。 ws.Range("A1").AutoFilter Field:=1, Criteria1:=tmp ws.Copy After:=newWb.Sheets(wsIndex)
この部分を、
ws.Autofilter.Rang.AutoFilter Field:=1, Criteria1:=tmp ws.Autofilter.Rang.Copy After:=newWb.Sheets(wsIndex) のようにやったらどうか等、色々検証するもエラーで解決できません。
また、下記のコードでは、一応名前が該当無しの場合もシート生成されました。不要なシートも1枚目に「Sheet1」と生成されてしまいますが、後で削除すれば何とかやりたいことは実現できそうな気がします、、、無理やりですが。
Sub Test中()
Dim 分割元 As Workbook Dim folderPath As String Dim i As Long Dim ws As Worksheet Dim MyDic As Object Dim tmp As Variant Dim newWb As Workbook Dim wsIndex As Long
Set MyDic = CreateObject("Scripting.Dictionary")
' 分割元のファイルを読み取り専用で開く Set 分割元 = Workbooks.Open(Filename:=ThisWorkbook.Sheets("設定").Range("A2").Value, ReadOnly:=True) ' フォルダパスを取得 folderPath = ThisWorkbook.Sheets("設定").Range("A1").Value
Application.ScreenUpdating = False
' 名前の一覧を取得 For Each ws In 分割元.Sheets If ws.name <> "まとめ" Then For i = 2 To ws.Cells(ws.Rows.Count, "A").End(xlUp).Row If Not MyDic.Exists(ws.Cells(i, 1).Value) Then MyDic.Add ws.Cells(i, "A").Value, "" Next i End If Next ws
' 各名前ごとにファイルを作成 For Each tmp In MyDic.keys Set newWb = Workbooks.Add wsIndex = 1 For Each ws In 分割元.Sheets If ws.name <> "まとめ" Then ws.AutoFilterMode = False ws.Range("A1").AutoFilter Field:=1, Criteria1:=tmp
ws.Copy After:=newWb.Sheets(wsIndex) wsIndex = wsIndex + 1
End If Next ws
' 新しいブックの保存 (既にファイル存在の場合は上書きするように警告無視) Application.DisplayAlerts = False newWb.SaveAs folderPath & "\" & tmp & "_まとめ.xlsx" newWb.Close SaveChanges:=True Application.DisplayAlerts = True
Next tmp
' 分割元のファイルを閉じる 分割元.Close SaveChanges:=False Application.ScreenUpdating = True End Sub (ぽぽ) 2024/04/14(日) 09:05:44
私も横からですが何点か。
■1
ループ途中に毎回↓を実行してますが、1回でよいと思います
ws.AutoFilterMode = False
■2
>例えばaさんは1つのシートしか該当ない場合もシート作成して項目名だけ残したい
発想を変えて、
1. まとめシート以外を(新規ブックへ)コピーする(or全シートをコピーしてからまとめシートを削除する) 2. ↑の全シートを巡回してaさん【以外】を抽出して項目行以外を削除する 3. (確認メッセージなしで)ブックを保存する
といったアプローチでもよいと思います。
(もこな2) 2024/04/14(日) 09:16:40
(隠居Z) 2024/04/14(日) 10:45:13
Option Explicit Private Sub LetFilter_Ws(ws, mkey) With ws With .Cells(1) .AutoFilter 1, mkey .CurrentRegion.Copy .Cells(1, 10) .AutoFilter End With .Range("A:I").Delete End With End Sub こんな感じ。。。^^; 当該のワークシートと当該のマスターキー「例、"aさん"」を渡してやります ほんの一例です(*^^*)/// m(__)m (隠居Z) 2024/04/14(日) 12:12:48
皆さんからコメントありましたので、解決済かもしれませんが、補足説明します。
見出しも含めてコピーするのであれば、 Set rng = ws.[A1].CurrentRegion としておいて、単に rng.Copy newWb.Sheets(wsIndex).[A1] で良かったですね。(*)
なお、転記先のシートを順次指定する部分はそちらで適切に対応してください. (つまり、必要なシートを確保する部分ですね。)
(上記の* についての補足) ・通常は、見出しを除く本体部分だけをコピーするケースが多く、 その場合、該当データが無いケースでは、なぜかデータ全体がコピーされてしまいます。 ・これを防止するために、 Application.WorksheetFunction.Subtotal(103, ws.Columns(1)) > 1 のようなヒットしたデータ行を算出して、場合分けする必要があるわけです。 ・しかし、見出しを含めてコピーする場合は、 上記のような場合分けは不要で、該当データが無い場合は、見出しだけがコピーされるのでした。
少しミスリーディングなコメントでした。失礼しました。
(xyz) 2024/04/14(日) 13:09:42
xyz様のコードをそのまま使うと
Rng.Copy newWb.Sheets(wsIndex).[A1] の部分で2巡目にシートが無いためにエラーがでます。
Rng.Copy After:=newWb.Sheets(wsIndex).[A1] にすると、.[A1]を付けているからか?エラーで稼働できません。
更に、Rngをやめて、下記で試すと、結果は貼りつくが、今度はシート名が元のシート名にならず、Sheet1, 2, 3・・・のようになってしまいます。
ws.Range("A1").AutoFilter Field:=1, Criteria1:=tmp
Set newWs = newWb.Sheets.Add(After:=newWb.Sheets(newWb.Sheets.Count))
ws.UsedRange.Copy newWs.Range("A1")
xyz様のコードをそのままあてはめたもの
Sub Test中()
Dim 分割元 As Workbook Dim folderPath As String Dim i As Long Dim ws As Worksheet Dim MyDic As Object Dim tmp As Variant Dim newWb As Workbook Dim wsIndex As Long Dim Rng As Range
Set MyDic = CreateObject("Scripting.Dictionary")
' 分割元のファイルを読み取り専用で開く Set 分割元 = Workbooks.Open(Filename:=ThisWorkbook.Sheets("設定").Range("A2").Value, ReadOnly:=True) ' フォルダパスを取得 folderPath = ThisWorkbook.Sheets("設定").Range("A1").Value
Application.ScreenUpdating = False
' 名前の一覧を取得 For Each ws In 分割元.Sheets If ws.name <> "まとめ" Then For i = 2 To ws.Cells(ws.Rows.Count, "A").End(xlUp).Row If Not MyDic.Exists(ws.Cells(i, 1).Value) Then MyDic.Add ws.Cells(i, "A").Value, "" Next i End If Next ws
' 各名前ごとにファイルを作成 For Each tmp In MyDic.keys Set newWb = Workbooks.Add wsIndex = 1 For Each ws In 分割元.Sheets If ws.name <> "まとめ" Then ws.AutoFilterMode = False
ws.Range("A1").AutoFilter Field:=1, Criteria1:=tmp Set Rng = ws.[A1].CurrentRegion Rng.Copy newWb.Sheets(wsIndex).[A1]
wsIndex = wsIndex + 1
End If Next ws
' 新しいブックの保存 (既にファイル存在の場合は上書きするように警告無視) Application.DisplayAlerts = False newWb.SaveAs folderPath & "\" & tmp & "_まとめ.xlsx" newWb.Close SaveChanges:=True Application.DisplayAlerts = True
Next tmp
' 分割元のファイルを閉じる 分割元.Close SaveChanges:=False Application.ScreenUpdating = True End Sub
(ぽぽ) 2024/04/14(日) 16:05:48
Rem ******************************************************************************** For Each ws In 分割元.Sheets If ws.Name <> "まとめ" Then If wsIndex > 1 Then newWb.Worksheets.Add after:=newWb.Worksheets(wsIndex - 1) ws.AutoFilterMode = False ws.Range("A1").AutoFilter Field:=1, Criteria1:=tmp Set Rng = ws.[A1].CurrentRegion Rng.Copy newWb.Sheets(wsIndex).[A1] newWb.Sheets(wsIndex).Name = ws.Name wsIndex = wsIndex + 1 End If Next ws Rem *******************************************************************************
うんなかんじでは。。。どうなるでせう。。。何シートあるのでせうね?^^;
処理速度がすこぉし気になります^^;
m(__)m
(隠居Z) 2024/04/14(日) 16:46:39
色々とありがとうございます。
みなさまからのF/B、大変参考になります。フローが大切なこと、よく分かりました。。
(ぽぽ) 2024/04/14(日) 17:08:55
(隠居Z) 2024/04/14(日) 17:59:03
Sub ちょっと別案() Dim i As Long, c As Long Dim ws As Worksheet Dim MyDic As Object Dim 分割元 As Workbook Dim シート名群() As String Dim tmp As Variant
Set 分割元 = Workbooks.Open(Filename:=ThisWorkbook.Sheets("設定").Range("A2").Value, ReadOnly:=True) Set MyDic = CreateObject("Scripting.Dictionary")
For Each ws In 分割元.Sheets If ws.Name <> "まとめ" Then ws.AutoFilterMode = False ws.Range("A1").AutoFilter
ReDim Preserve シート名群(c) As String シート名群(c) = ws.Name c = c + 1
For i = 2 To ws.Cells(ws.Rows.Count, "A").End(xlUp).Row If Not MyDic.Exists(ws.Cells(i, 1).Value) Then MyDic.Add ws.Cells(i, "A").Value, "" Next i End If Next ws
Application.DisplayAlerts = False For Each tmp In MyDic.keys '▼まとめシート以外を新規ブックにコピーする 分割元.Worksheets(シート名群).Copy
With Workbooks(Workbooks.Count) For Each ws In .Worksheets '▼対象"以外"を抽出して削除する ws.AutoFilter.Range.AutoFilter Field:=1, Criteria1:="<>" & tmp ws.AutoFilter.Range.Offset(1).Delete On Error Resume Next ws.ShowAllData On Error GoTo 0 Next ws
.SaveAs Filename:=ThisWorkbook.Sheets("設定").Range("A1").Value & "\" & tmp .Close False End With Next tmp Application.DisplayAlerts = True End Sub
(もこな2) 2024/04/14(日) 18:45:11
(隠居Z) 2024/04/14(日) 19:41:38
みなさま、色々教えていただき、ありがとうございました。
(ぽぽ) 2024/04/14(日) 20:25:58
質問者さんのコードの延長線にあるものを参考までに示します。 学習の参考になればよいと思います。
Sub test() Dim folderPath As String Dim fullPath As String Dim 分割元 As Workbook Dim sheetsCount As Long Dim dic As Object Dim i As Long Dim k As Long Dim ws As Worksheet Dim key As Variant Dim newWb As Workbook Dim newWs As Worksheet Dim rng As Range
Application.ScreenUpdating = False
'分割元Bookを開く folderPath = ThisWorkbook.Sheets("設定").Range("A1").Value fullPath = ThisWorkbook.Sheets("設定").Range("A2").Value Set 分割元 = Workbooks.Open(Filename:=fullPath, ReadOnly:=True) sheetsCount = 分割元.Worksheets.Count
' 名前の一覧を取得 Set dic = CreateObject("Scripting.Dictionary") For Each ws In 分割元.Sheets If ws.Name <> "まとめ" Then For i = 2 To ws.Cells(ws.Rows.Count, "A").End(xlUp).Row dic(ws.Cells(i, "A").Value) = Empty Next End If Next ws
' 各名前ごとに転記先ブックを作成して転記 For Each key In dic.keys k = 0 Set newWb = makeNewWorkbook(sheetsCount - 1) '転記先ブックを作成 For Each ws In 分割元.Sheets If ws.Name <> "まとめ" Then k = k + 1 Set newWs = newWb.Worksheets(k) newWs.Name = ws.Name
'A列がkeyであるデータのみ抽出してコピーペイスト ws.Range("A1").AutoFilter Field:=1, Criteria1:=key ws.[A1].CurrentRegion.Copy newWs.[A1] ws.AutoFilterMode = False End If Next ws
Application.DisplayAlerts = False newWb.SaveAs folderPath & "\" & key & "_まとめ.xlsx" newWb.Close SaveChanges:=False Application.DisplayAlerts = True Next key
' 分割元のファイルを閉じる 分割元.Close SaveChanges:=False Application.ScreenUpdating = True End Sub
Function makeNewWorkbook(シート数 As Long) As Workbook Dim buf As Long buf = Application.SheetsInNewWorkbook '自動で作成するシート数の設定を記憶 Application.SheetsInNewWorkbook = シート数 Set makeNewWorkbook = Workbooks.Add Application.SheetsInNewWorkbook = buf '’自動で作成するシート数の設定を復旧 End Function
(注記) 分割元ブックのシート名は、Workbooks.Addで作成される通常のSheet1,Sheet2・・・とバッティングしないことが条件です。 (例えば、分割元ブックの最初のシート名が Sheet2 だったりすると、 newWs.Name = ws.Name を実行した時点でシート名がバッティングしてエラーになります。) (xyz) 2024/04/14(日) 23:34:32
(隠居Z) 2024/04/15(月) 09:45:34
(トピ主が提示したコードの延長線なのであえてということなのかもしれませんが)
Sub test_別案() Dim 分割元 As Workbook Dim dic As Object Dim i As Long, k As Long Dim ws As Worksheet Dim key As Variant Dim newWb As Workbook
'分割元Bookを開く Set 分割元 = Workbooks.Open(Filename:=ThisWorkbook.Sheets("設定").Range("A2").Value, ReadOnly:=True)
' 名前の一覧を取得 Set dic = CreateObject("Scripting.Dictionary") For Each ws In 分割元.Sheets If ws.Name <> "まとめ" Then ws.AutoFilterMode = False ws.Range("A1").AutoFilter For i = 2 To ws.Cells(ws.Rows.Count, "A").End(xlUp).Row dic(ws.Cells(i, "A").Value) = Empty Next End If Next ws
' 各名前ごとに処理 For Each key In dic.keys Set newWb = Workbooks.Add(xlWBATWorksheet) '引数を指定するとそのタイプのシート1枚だけのブックができる newWb.Worksheets(1).Name = "後で削除するシート" '名前被り対策(持ってくるシートがSheet1じゃなきゃ不用)
'まとめシート以外を順番に処理(抽出して、全体をコピーして、シートを追加してから貼付する) For Each ws In 分割元.Sheets If ws.Name <> "まとめ" Then ws.Range("A1").AutoFilter Field:=1, Criteria1:=key ws.AutoFilter.Range.Copy Worksheets.Add(after:=newWb.Worksheets(newWb.Worksheets.Count)).Range("A1") newWb.Worksheets(newWb.Worksheets.Count).Name = ws.Name End If Next ws
Application.DisplayAlerts = False newWb.Worksheets(1).Delete '最初のシートはここで削除 newWb.SaveAs ThisWorkbook.Sheets("設定").Range("A1").Value & "\" & key & "_まとめ.xlsx" newWb.Close SaveChanges:=False Application.DisplayAlerts = True Next key
' 分割元のファイルを閉じる 分割元.Close SaveChanges:=False Application.ScreenUpdating = True End Sub
あと、セル範囲をコピーするアプローチだと、行高や列幅にこだわりがある場合ちょっと面倒かもしれません。
(もこな2) 2024/04/16(火) 07:08:13
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.