[[20240413085244]]　『マクロで各シートの表を条件に沿ってファイルを分』（ぽぽ）　ページの最後に飛ぶ

『マクロで各シートの表を条件に沿ってファイルを分割したい』（ぽぽ）

表題の件、教えてください。
マクロが入っている「設定」シートの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

整理のお手伝いだけども。。。＾＾
０．指定のブック開く
１．全シート読み込んで名前マスタ作成
２．マスタをキーに名前を加工して、名前を変えて保存
３．保存先のブックで当該シートをマスタでフイルタしたものに置き換え
４．全シート３．の処理して保存
５．２～４全マスタ分繰り返す
６．後始末して御終い
いろいろ。。。様々な方法が有るとはぞんじますが↑
みたいなことでも出来るかもしれませんですね(￣▽￣)　←かなりいいかげん^^;
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

編集が被りましたがそのまま。

私も横からですが何点か。

■１
ループ途中に毎回↓を実行してますが、１回でよいと思います

 ws.AutoFilterMode = False

■２
＞例えばaさんは1つのシートしか該当ない場合もシート作成して項目名だけ残したい

発想を変えて、

 1. まとめシート以外を（新規ブックへ）コピーする（or全シートをコピーしてからまとめシートを削除する）
 2. ↑の全シートを巡回してaさん【以外】を抽出して項目行以外を削除する
 3. （確認メッセージなしで）ブックを保存する

といったアプローチでもよいと思います。
（もこな２） 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

（もこな２） 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) '引数を指定するとそのタイプのシート１枚だけのブックができる
        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

あと、セル範囲をコピーするアプローチだと、行高や列幅にこだわりがある場合ちょっと面倒かもしれません。

（もこな２） 2024/04/16(火) 07:08:13

コメント返信：

[ 一覧(最新更新順) ]

[[20240413085244]] 『マクロで各シートの表を条件に沿ってファイルを分』（ぽぽ） ページの最後に飛ぶ

[[20240413085244]]　『マクロで各シートの表を条件に沿ってファイルを分』（ぽぽ）　ページの最後に飛ぶ