Results of 1 - 1 of about 295 for cell filename (0.001 sec.)
cell (1170), filename (1984)
- [[20240413085244]]
- #score: 11157
- @digest: 1085e380c85700ecf9f9d4ea2360e32c
- @id: 96596
- @mdate: 2024-04-15T22:08:13Z
- @size: 24274
- @type: text/plain
- #keywords: 割元 (206193), wsindex (184530), newwb (80493), 元. (45588), folderpath (19290), 分割 (19086), 定") (17398), savechanges (9711), 居z (7745), mydic (7584), autofilter (7199), autofiltermode (6124), 2024 (5708), ws (5387), displayalerts (5213), ト数 (4943), criteria1 (4807), 隠居 (4665), sheets (4220), 生成 (3689), tmp (3632), シー (3620), workbooks (3615), workbook (3116), application (3035), ート (2917), ファ (2833), 名前 (2635), after (2587), 日) (2566), thisworkbook (2558), screenupdating (2426)
- 『マクロで各シートの表を条件に沿ってファイルを分割したい』（ぽぽ）
表題の件、教えてください。 マクロが入っている「設定」シートの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 ---- ありがとうございます。 隠居Z様のヒントを元に1日考えてみましたが、うまくいかず、、、 近い所までいった気はするのですが、色々おかしな部分があります(^^; ご教授いただけますと嬉しいです。 うまくいかないのは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 ---- こんばんわ。。。^^ 本日午後より外出しておりまして、只今、拝見いたしました。 まだチラ見状態ですので。今からお勉強させて戴きますです。私、浅学菲才のうえ、ぼけ老人ですので 理解させて戴くのに大分お時間がかかります。 他の回答者様のアドバイスもお待合わせの上、気長にお待ち戴ければ幸甚です。 取り急ぎご挨拶まで。。。m(__)m ^^; m(__)m （隠居Z） 2024/04/13(土) 19:44:33 ---- お世話になります。 ＞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 ---- xyz様 上書き処理は、警告エラー無視すれば良かったのですね。こちらの方がシンプルですね。非常に参考になりました。 ＞どのかたも、元のブックのシートの数と同じだけのシートが必要なんですか? 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 ---- おはようございます。。。^^ ほぼ。。。完成ですねぇ そのままシートコピーするとフイルターかかったままなので、xyz さんご案内の様に 先頭セル.カレントレジオンをコピペで転記先シートのcell(1)へほり込んであげると 良いかもしれません。。。←多分ですが。。。^^;。ちなみに実際は何シート有るのか 教えて戴けるとうれしいです。ブック操作、お勉強になりました有難う御座います。 m(__)m （隠居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 ---- 横入りすみませんん。。。m(__)m え〜と ブック追加するとシート1個付きなので^^; ちょこっと 小細工を(*^^*) 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 ---- 隠居Z様 ありがとうございます。 なるほど、シート操作もIfで分岐させてしまうのですね。 とても勉強になります。 シート数、すみませんお答えするの漏れていました。。シート数自体はそんなにありません。 変動しますが、10シートまではいかないと思います。 元データの行数がかなり多いのと、分割するファイル数は多いですが、フィルタでやってしまえば耐えられるかと思っております。 色々とありがとうございます。 みなさまからのF/B、大変参考になります。フローが大切なこと、よく分かりました。。 （ぽぽ） 2024/04/14(日) 17:08:55 ---- シート数、ありがとうございます。 お名前の数×シート数ですかね。。。機嫌よく動けば良いのですが 固まる様でしたら。Doevents をループの何処かに置けば回避できるかも^^; すこしその分遅くはなりますが。老婆心まで。。。気にしないでくださいませ でわ、失礼致します。m(__)m （隠居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 ---- ↑ おお。。。逆転の発想ですね ^^ ブックのコピー方法と フイルタの使用方法 とても勉強になりました。 使わせて戴きます。^^; m(__)m （隠居Z） 2024/04/14(日) 19:41:38 ---- もこな2様 いろいろな発想ができますね。 ありがとうございます。とても参考になります。 みなさま、色々教えていただき、ありがとうございました。 （ぽぽ） 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 ---- おはようございます ^^ ぽぽ さんお邪魔してすみません ↑ 拝見いたしました。(*^^*)。。新規ブック作成方法 ほんと様々な方法がありますねぇ。。。とても勉強になります。ありがとうございます。 ( ..)φメモメモ でわ m(__)m （隠居Z） 2024/04/15(月) 09:45:34 ---- あくまで私の感覚ですが、コピペ作戦のほうで行くにしても都度シートを追加すればよく、「SheetsInNewWorkbook」をいじる必要はさほど高くないのではないかと思います。 （トピ主が提示したコードの延長線なのであえてということなのかもしれませんが） 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... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/202404/20240413085244.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97054 documents and 608269 words.
訪問者：