[[20221001175637]]　『オートフィルタの結果ごと特定の名前をつけて別ブ』（悲願）　ページの最後に飛ぶ

『オートフィルタの結果ごと特定の名前をつけて別ブックとして保存』（悲願）

よろしくお願いします。
実行したいことは表題の通りです。

在庫.xlsxのsheet1

       A       B         C       D
 1   図版     形式　　　部署    管理No ←この行にオートフィルター
 2    ASD     QWE       製造     s-2
 3    SDF     QRT       製造     s-2
 4    FGH     OOP       品質     s-4
 5    VFG     SND       購買     s-1
 6    BGH     ALP       総務     s-3
 7    ZXC     QER       総務     s-3
 8    CVD     RIR       品質     s-4
 9    ASW     NNK       購買     s-1

C列のオートフィルターで昇順に並び替えて管理Noを付けてあります。

デスクトップにある管理というフォルダに
【s-01】購買.xlsx、【s-02】製造.xlsx、【s-03】総務.xlsx、【s-04】品質.xlsxというブックで保存したいのです。

【s-01】購買.xlsxのsheet1

       A       B         C       
 1   図版     形式　　　部署
 2    VFG     SND       購買
 3    ASW     NNK       購買

【s-02】製造.xlsxのsheet1

       A       B         C      
 1   図版     形式　　　部署
 2    ASD     QWE       製造     
 3    SDF     QRT       製造

というような感じにファイルを保存したいのです。

現在はオートフィルタの結果をコピーして、名前をつけて保存を繰り返しています。
例示の管理Noは4件ですが、実際はもっとたくさんあり、この作業だけでとてつもない時間を費やしていまいます。
管理Noですがいつも「s-何番」というわけでなく、「業務部-NO何番」や他にも都度変わります。
どうにかして自動化する方法をご教示ください。
どうかよろしくお願いします。

＜使用 Excel：Excel2019、使用 OS：Windows10 ＞

＞どうにかして自動化する方法
おそらくマクロでの対応になると思います。
手順としてはこんな感じ。

 1. C列の内容から重複のないリストを得る
 2. ↑のリストを条件にしてオートフィルタで【抽出】する
 3. 抽出されている表範囲のうち、A～C列をコピーする
 4. 新規ブックを開く（追加する）
 5. ↑の1番目のシートのA1セルに【貼付】する
 6. ↑のブックを【名前を付けて保存】する

＞現在はオートフィルタの結果をコピーして、名前をつけて保存
まずは、その手順を【マクロの記録】を行ってコード化してみてはどうですか？
繰り返し部分と、重複の内リストの部分は別にして、必要な命令の大半を調べることができると思います。

（もこな２） 2022/10/01(土) 19:15

１．　シェルを生成
２．　フォルダ確認[無ければ作成]
３．　連想配列を生成
４．　処理範囲を変数と配列に格納、シートコピー
５．　配列から３．を使い部署の一意なキー作成
６．　部署キーをループ
７．　４．のアクティブシートを初期化
８．　フイルター詳細の条件を記入
９．　範囲をフイルター詳細で書き出し
１０．8.を削除
１１．Ｄ列を削除
１２．新規ブックとしてコピー
１３．名前を付けて保存
１４．１２．のブックを閉じる
１５．６．のループ終了後、４．の作業シート削除
１６．後処理
とかでもと思ったのですが。。。そのぉ
～(*^ ^*)
管理No。。。は手入力ですかぁ？ありゃま。。。どうすれば
何処かに、管理番号と部署名の対応表があれば、何とか...^^;
m(__)m

（隠居Z） 2022/10/02(日) 13:41

失礼致しました。
最初から、管理番号は入力済、とのご前程でしたら
↑で何とか成りそうな気がいたしますです。
でわ
m(_ _)m
（隠居Z） 2022/10/02(日) 13:52

自動化、自動化って本人は何もしないでただ待っているというのが
気に食わないです。
マクロ記録すらしないようですので
どこかに有料で作ってもらったら。

（無料依頼所ではない） 2022/10/02(日) 14:21

Sub Macro3()

' Macro3 Macro

    Selection.AutoFilter Field:=5, Criteria1:="購買"
    Range("A1:C2").Select
    Selection.Copy
    Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveWorkbook.SaveAs Filename:="C:\Users\xxxxxx\Desktop\Amada\【s-01】購買.xlsx", FileFormat _
        :=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
        False, CreateBackup:=False
End Sub

もこな２さん
おかげで自動で作れるようになりました。
ありがとうございます。

隠居Zさん
ありがとうございます。
私の理解が全く及ばず申し訳ありません。

無料依頼所ではないさん
ただ待っていたわけではないのですが、そのように思われたのなら謝罪いたします。
（悲願） 2022/10/02(日) 18:30

＞管理Noですがいつも「s-何番」というわけでなく、「業務部-NO何番」や他にも都度変わります

そんな曖昧なことでは自動化できません。

 Sub test()
    Dim ws As Worksheet, wb As Workbook
    Dim cri As Range, dst As Range
    Dim p As String, no As String, fn As String

    Set ws = Workbooks("在庫.xlsx").Worksheets("Sheet1")
    Set cri = ws.Range("G1:F1")
    ws.Copy

    Set wb = ActiveWorkbook
    Set dst = wb.Worksheets(1).Range("A1:C1")
    wb.Worksheets(1).Columns("D").Delete

    p = CreateObject("wscript.shell").specialfolders("desktop") & "\管理\"

    ws.Columns("C:D").AdvancedFilter xlFilterCopy, , cri, True

    Do While cri(2, 1).Value <> ""
        no = Format(Replace(Split(cri(2, 2), "-")(1), "NO", ""), "00")
        fn = "【s-" & no & "】" & cri(2, 1).Value & ".xlsx"
        ws.Columns("A:D").AdvancedFilter xlFilterCopy, cri.Resize(2), dst
'        wb.SaveAs p & fn, xlOpenXMLWorkbook
        cri.Rows(2).Delete xlShiftUp
    Loop
    wb.Close False
    cri.Clear

 End Sub

（マナ） 2022/10/02(日) 18:53

マナさん
ありがとうございます。

そんな曖昧なことでは自動化できません。
仰る通りです。申し訳ありませんでした。

半平太さん
18時頃の投稿が消えていますが、ありがとうございました。
マクロのメモは間に合いませんでしたが、作成に貴重なお時間を割いていただきありがとうございました。
（悲願） 2022/10/02(日) 21:44

もう一度お願いします。
10/5　13時までに1回返信を入れるようにします。

 　　　A　　　　　　　　　　B　　　　　C　　　　　　　D　　　　　　E　　　　　　F　　　　　　　　　　　H
 1　　パーツコード　　　　型番　　　　客先型番　　　メーカー　　　仕入先　　　　仕入先（重複なし）　　管理NO
 2　　123                AAA            ZZZ           A             A商事　　　　A商事　　　　　　　　　S-01
 3    410                BBB            UUU           B             C商事　　　　B商事　　　　　　　　　S-02
 4    789                CCC            YYY           C             A商事　　　　C商事　　　　　　　　　S-03
 5    467                DDD            KKK           D             B商事

１　E列の仕入れ先ごと別のブックにまとめたい。
　　ブック名は【S-01】A商事.xlsx、【S-02】B商事.xlsx、【S-03】C商事.xlsxというようにしたい。

F列に重複なしの仕入先、H列に管理NO
h　ttps://hamachan.info/excel/jyuuhuku.html
上記サイトを参考に重複なしの仕入先を作成しました。

h　ttps://fastclassinfo.com/entry/vba_file_tenki/
上記サイトを参考(ほぼ丸写しですが)にして以下のようなマクロを作成しました。

【S-01】のような番号をつけるにはどうしたらよいのでしょうか。

newfilename = "【S-01】" & "_" & torihiki & ".xlsx"
のようにするとずっと【S-01】のままです。

'プログラム0｜変数設定の指定
Option Explicit

'プログラム1｜プログラム開始
Sub TEST()

    'プログラム2｜シート設定
    Dim ws1 As Worksheet
    Set ws1 = ThisWorkbook.Worksheets("nouhin")

    'プログラム3｜最終行を取得
    Dim cmax1 As Long
    cmax1 = ws1.Range("A65536").End(xlUp).Row

    'プログラム4｜「nouhin」シートをコピーして重複削除
    Dim ws2 As Worksheet
    ws1.Copy after:=Worksheets(Worksheets.Count)
    Set ws2 = ActiveSheet
    ws2.Range("A:E").RemoveDuplicates Columns:=Array(5), Header:=xlYes

    'プログラム5｜プログラム4で重複削除したシートの最終行を取得
    Dim cmax2 As Long
    cmax2 = ws2.Range("A65536").End(xlUp).Row

    'プログラム6｜プログラム4で重複削除したシートのA列を2行目から最終行まで処理
    Dim i As Long
    For i = 2 To cmax2
        Dim torihiki As String
        torihiki = ws2.Range("A" & i).Value

        'プログラム7｜「template.xlsx」を開く
        Dim wb As Workbook
        Set wb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\template.xlsx")

        'プログラム8｜「template」シートを設定して名前を変更
        Dim ws3 As Worksheet
        Set ws3 = wb.Worksheets("template")
        ws3.Name = torihiki

        'プログラム9｜転記先の行数をn=2で初期化
        Dim n As Long: n = 2

        'プログラム10｜「nouhin」シートのA列がtorihikiと一致したら転記
        Dim j As Long
        For j = 2 To cmax1
            If torihiki = ws1.Range("A" & j).Value Then
                ws3.Range("A" & n & ":E" & n).Value = ws1.Range("A" & j & ":E" & j).Value
                n = n + 1
            End If
        Next

        'プログラム11｜転記が完了したエクセルを保存して閉じる
        Dim newfilename As String
        newfilename = Format(Date, "yyyy-mm-dd") & "_" & torihiki & ".xlsx"
        Application.DisplayAlerts = False
        wb.SaveAs Filename:=ThisWorkbook.Path & "\" & newfilename
        Application.DisplayAlerts = True
        wb.Close

        'プログラム12｜オブジェクト解放
        Set ws3 = Nothing
        Set wb = Nothing
    Next

    'プログラム13｜プログラム4で作成した重複削除シートを削除
    Application.DisplayAlerts = False
    ws2.Delete
    Application.DisplayAlerts = True

'プログラム14｜プログラム終了
End Sub

（悲願） 2022/10/04(火) 23:32

ちょっと確認ですが「管理NO」の列は、"s-2"、"S-01"どっちなんですか？
＞管理Noですがいつも「s-何番」というわけでなく、「業務部-NO何番」や他にも都度変わります。
とのことですが、ファイル名に【セルの値をそのまま使う】のは難しくありませんが、当初提示されたように【数字の部分を取り出して桁埋めして書き戻す】のは考えることが増えてしまいます。

（もこな２） 2022/10/05(水) 07:59

 Option Explicit
Sub txmk()
    Dim i As Long
    ReDim aAry(1 To 3, 1 To 2)
    aAry(1, 1) = "A商事": aAry(1, 2) = "S-01"
    aAry(2, 1) = "B商事": aAry(2, 2) = "S-02"
    aAry(3, 1) = "C商事": aAry(3, 2) = "S-03"
    For i = 1 To 3
        MsgBox "【" & aAry(i, 2) & "】" & "_" & aAry(i, 1) & ".xlsx"
    Next
End Sub
（隠居Z） 2022/10/05(水) 08:07

 １．「仕入先(重複なし）」と「管理NO」は既に出来上がった後で実行するマクロですね？
 ２．「管理NO」は本当にH列にあるんですね？（G列がないですけども）

 在庫ブックは開いてあるものとします。

 Sub Sample()
     Dim FolderPathOnDesk As String, i As Long, BkPrefix As String
     Dim r As Range, rTop As Range, rBottom As Range
     Dim WsHelper As Worksheet, refTBL As Range

     '在庫ブックをコピーして、Helperブックを作る。
     Workbooks("在庫.xlsx").Sheets("Sheet1").Copy
     Set WsHelper = ActiveWorkbook.Sheets(1)

     With WsHelper
         .AutoFilterMode = False
         With .Sort
             .SortFields.Clear
             .SortFields.Add Key:=Range("E1"), SortOn:=xlSortOnValues, Order:=xlAscending
             .SetRange Columns("A:E")
             .Header = xlYes
             .Orientation = xlTopToBottom
             .Apply
         End With

         Set r = .Range("A1:E1").Resize(.Cells(.Rows.Count, "A").End(xlUp).Row)
         Set rTop = .Range("A2")
         Set refTBL = .Range("F2").Resize(r.Rows.Count - 1, 3) '管理NO参照テーブル(F:H)
     End With

     FolderPathOnDesk = CreateObject("WScript.Shell").specialfolders("Desktop") & "\管理\"

     Application.ScreenUpdating = False
     Application.DisplayAlerts = False

     For i = 3 To r.Rows.Count + 1 '3行目からチェック開始
         With WsHelper.Cells(i, "E")
             If .Value <> .Offset(-1) Then '真なら前行までが転記対象
                 Set rBottom = .Offset(-1)
                 Union(r.Rows(1), Range(rTop, rBottom)).Copy  'コピペ実行

                 With Workbooks.Add.Sheets(1)
                     .Paste
                     .SaveAs Filename:=FolderPathOnDesk & newFilename(rBottom, refTBL), _
                     FileFormat:=xlOpenXMLWorkbook
                     ActiveWorkbook.Close
                 End With

                 Set rTop = WsHelper.Cells(i, "A")
             End If
         End With
     Next i

     WsHelper.Parent.Close False
     Application.DisplayAlerts = True
     Application.ScreenUpdating = True
 End Sub

 Private Function newFilename(Customer As Range, refTBL As Range)
     Dim ret
     ret = Application.VLookup(Customer, refTBL, 3, False)

     If Not IsError(ret) Then
         newFilename = "【" & ret & "】" & Customer.Value
     Else
         newFilename = "【 】" & Customer.Value
     End If
 End Function

（半平太） 2022/10/05(水) 09:31

いろんな案が提示されておなかいっぱいかもしれませんが、提示しておきます。
興味があれば【ステップ実行】して研究のうえ、必要な部分のみご自身のコードに組み込んで下さい。

 ※完成品のプレゼントを意図した物ではありませんので、丸パクリして完成！というのはご遠慮下さい。

【在庫.xlsx の sheet1】

       A       B         C       D
 1   図版     形式　　　部署    管理No
 2    ASD     QWE       製造     s-2
 3    SDF     QRT       製造     s-2
 4    FGH     OOP       品質     s-4
 5    VFG     SND       購買     s-1
 6    BGH     ALP       総務     s-3
 7    ZXC     QER       総務     s-3
 8    CVD     RIR       品質     s-4
 9    ASW     NNK       購買     s-1

↑のようなデータの時に、項目行ごと切り出して(複製して）↓のようなファイル名で「在庫.xlsx」と同じフォルダに保存

 【s-1】購買.xlsx
 【s-2】製造.xlsx
 【s-3】総務.xlsx
 【s-4】品質.xlsx

    Sub 研究用()
        Dim tmpSH As Worksheet
        Dim i As Long
        Dim ファイル名 As String

        Stop 'ブレークポイントの代わり

        Set tmpSH = Worksheets.Add(before:=ThisWorkbook.Worksheets(1))

        With Workbooks("在庫.xlsx").Worksheets("Sheet1")
            .AutoFilterMode = False
            .Range("A1").AutoFilter

            Intersect(.AutoFilter.Range, .Range("C:D")).Copy tmpSH.Range("A1")

            tmpSH.Range("A1").CurrentRegion.RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes

            For i = 2 To tmpSH.Cells(tmpSH.Rows.Count, "A").End(xlUp).Row
                ファイル名 = "【" & tmpSH.Cells(i, "B").Value & "】" & tmpSH.Cells(i, "A").Value

                .AutoFilter.Range.AutoFilter Field:=3, Criteria1:=tmpSH.Cells(i, "A").Value
                Intersect(.AutoFilter.Range, .Range("A:C")).Copy Workbooks.Add.Worksheets(1).Range("A1")

                Workbooks(Workbooks.Count).SaveAs Filename:=.Parent.Path & "\" & ファイル名
                Workbooks(Workbooks.Count).Close
            Next i
        End With

        Application.DisplayAlerts = False
        tmpSH.Delete
        Application.DisplayAlerts = True

    End Sub

（もこな２） 2022/10/05(水) 12:02

皆様ありがとうございます。

（もこな２）さん 2022/10/05(水) 07:59

ファイル名に【セルの値をそのまま使う】方でお願いします。

（隠居Z）さん 2022/10/05(水) 08:07
ありがとうございます。F8で動きを確認して勉強します。

（半平太）さん 2022/10/05(水) 09:31
1　すみません、非常に申し訳ないのですがおっしゃっている意味がわかりません。
　　私は　h　ttps://fastclassinfo.com/entry/vba_file_tenki/
　　上記サイトを丸パクリしてなんとなく動くものを作った（実際には"作っていない"ですが）だけです。
　　マクロはSub TEST()以下の1つだけだと思います。

2　G列で間違いないです。H列だと表と隣り合って見にくいかなと思い、1列開けてあります。

ありがとうございます。F8で動きを確認して勉強します。
　
（もこな２）さん 2022/10/05(水) 12:02
ありがとうございます。F8で動きを確認して勉強します。

（悲願） 2022/10/05(水) 12:40

 ＞1　すみません、非常に申し訳ないのですがおっしゃっている意味がわかりません。

 私の方が分からないですけど。

 在庫ブックのSheet1が下図のデータ状況に変更になったんでしょっ？

 <Sheet1 シート>
 行  ______A______  __B__  ____C____  ____D____  ___E___  _________F_________  _G_  ___H___
  1  パーツコード   型番   客先型番   メーカー   仕入先   仕入先（重複なし）        管理NO 
  2            123  AAA    ZZZ        A          A商事    A商事                     S-01   
  3            410  BBB    UUU        B          C商事    B商事                     S-02   
  4            789  CCC    YYY        C          A商事    C商事                     S-03   
  5            467  DDD    KKK        D          B商事

 そうだとして、F列の重複無しリストとH列の管理NOは、別途手作業かなんかで作ったんじゃないですか？
 私のマクロは、在庫ブックがその状態になっていれば、お望みの結果が出るように作ってあるんですけど。

 それとも、F列とH列も自動で作りたいってことなんですか？
 そうだとしたら、管理NOになるべき元データは一体何処にあるんですか？

 ＞F8で動きを確認して勉強します。
 全データの状況がお互い正しく認識できていないなら、
 今そんなことやったって時間の無駄です。

（半平太） 2022/10/05(水) 13:11

（半平太）さん 2022/10/05(水) 13:11

F列の重複無しリストとH列の管理NOは、別途手作業かなんかで作ったんじゃないですか？
はい、その通りです。

私のマクロは、在庫ブックがその状態になっていれば、お望みの結果が出るように作ってあるんですけど。
ありがとうございます。

それとも、F列とH列も自動で作りたいってことなんですか？
いいえ、F列、H列は手作業で作ります。

恥を重ねますが、デスクトップにcmrt.xlsxというブックがあり、そのsheet5のB6からD6へ在庫ブックのsheet1のA列B列C列を仕入れ先別にコピーするにはどういうマクロになりますか。
（悲願） 2022/10/05(水) 14:20

 ＞デスクトップにcmrt.xlsxというブックがあり、
 ＞そのsheet5のB6からD6へ在庫ブックのsheet1のA列B列C列を仕入れ先別にコピーするマクロ

 全く別の話ですね？

 １．デスクトップ上に直接在るんですね（いままでは、管理フォルダ内でしたけど）？

 ２．sheet5の「B6からD6」を先頭行にして、下に書き込むんですか？

 ３．在庫ブックのsheet1のA列B列C列に「仕入先」なんてデータはないですよね？
 　　そんなリストで、ユーザーは仕入先がどう区別出来るんですか？

（半平太） 2022/10/05(水) 15:42

こんばんわ。＾＾。。。例の如く恐怖の憶測と推測のデタラメコードです。
こんな感じですか？？
大きく外している気が致します。暇でしたので作ってみました。(￣▽￣)
cmrt.xlsxのSheet5、Ｂ～Ｄ列は初期化されます。ご注意を

 m(_ _)m
Option Explicit
Sub z2brw()
    Dim zB, cB, s, fps$, fs
    Dim r, v(), w(), lR&, i&
    Set zB = ThisWorkbook
    With zB.Worksheets("Sheet1")
        .Copy before:=Worksheets(1)
    End With
    With ActiveSheet
        .Range("F:H").Delete
        Set r = .Cells(1).CurrentRegion
        r.Sort key1:=r.Columns(5), order1:=xlAscending, Header:=xlYes
        v = r.Value
    End With
    ReDim w(1 To UBound(v, 1) - 1, 1 To 3)
    For i = 2 To UBound(v, 1)
        w(i - 1, 1) = v(i, 1)
        w(i - 1, 2) = v(i, 2)
        w(i - 1, 3) = v(i, 3)
    Next
    Set s = CreateObject("WScript.Shell")
    Set fs = CreateObject("Scripting.FileSystemObject")
    fps = s.specialfolders("Desktop") & "\cmrt.xlsx"
    If fs.FileExists(fps) Then
        Set cB = Workbooks.Open(fps)
    End If
    With cB.Worksheets("Sheet5")
        lR = .Cells(.Rows.Count, 2).End(xlUp).Row
        lR = IIf(lR < 6, 6, lR)
        Intersect(.Range("B:D"), .Range(.Rows(6), .Rows(lR))).Clear
        .Cells(6, 2).Resize(UBound(w, 1), UBound(w, 2)) = w
    End With
    cB.Close True
    zB.Save
    Erase v, w
    End
End Sub
（隠居Z） 2022/10/05(水) 19:43

（半平太）さん 2022/10/05(水) 15:42

全く別の話ですね？
申し訳ありません、まったく別の話です。

１．デスクトップ上に直接在るんですね（いままでは、管理フォルダ内でしたけど）？
申し訳ありません、デスクトップ上の紛争というフォルダ内にあります。

 ２．sheet5の「B6からD6」を先頭行にして、下に書き込むんですか？
https://home.jeita.or.jp/cgi-bin/topics/detail.cgi?n=3040&ca=848&ca2=
ここの一番下にある帳票というリンクから見本のxlsxをダウンロードすることができます。

RMI.xlsx（ダウンロードしたエクセルのブック）（Product Listシート）
行 _A_ ______________B______________ ____________C_______________ _______D______

 1
 2
 3
 4
 5         Manufacturer's Product Number     Manufacturer's Product Number     Comments
 6
 7
 8
 9

ダウンロードしたブックのProdut ListのB5からD5を先頭にして下に書き込みます。
1～4行は保護されています。
以下の表の仕入れ先ごとにSheet1のA2をRMI.xlsxのB6、Sheet1のB2をRMI.xlsxのC6、Sheet1のC2をRMI.xlsxのD6へ転記して管理Noをつけて保存したい。

<在庫.xlsxのSheet1 シート>

 行  ______A______  __B__  ____C____  ____D____  ___E___  _________F_________  _G_  ___H___
  1  パーツコード   型番   客先型番   メーカー   仕入先   仕入先（重複なし）        管理NO 
  2            123  AAA    ZZZ        A          A商事    A商事                     S-01   
  3            410  BBB    UUU        B          C商事    B商事                     S-02   
  4            789  CCC    YYY        C          A商事    C商事                     S-03   
  5            467  DDD    KKK        D          B商事

（悲願） 2022/10/06(木) 19:22

 ご隠居Zさんが、新しい情報を加味して再度作成してくれるんじゃないかと思いますので、
 少し待ってみてください。

（半平太） 2022/10/06(木) 23:01

こんばんわ。＾＾；
今日はもう眠いので、ご希望をよく読んで、明日でも、がんばってみます。(*^ ^*)v
m(__)m
（隠居Z） 2022/10/06(木) 23:20

↑　私はお勉強のために練習！頑張りますが、他の回答者様
も、ご興味が御有りでしたら、アドバイス、回答等々どんどん、お願い
いたします。←言い訳はいいからはよう作れ。。。←あ、はい＾＾；
m(__)m
（隠居Z） 2022/10/07(金) 06:40:59

最初から、気にはなっていたのですが
在庫.xlsx
は
どちらに、有りますかフルパス[デスクトップはデスクトップでOK＾＾；]を教えて下さい。
既に
開いている、が前程で、良いのでしたら、結構ですが
マクロが有るブックから、在庫.xlsxとRMI.xlsxを開いて操作
みたいな感じだと、推測いたします。
（隠居Z） 2022/10/07(金) 06:59:43

（半平太）さん 2022/10/06(木) 23:01
多々ご迷惑をおかけしました。大変申し訳ありませんでした。

（隠居Z）さん 2022/10/06(木) 23:20
申し訳ありませんが、よろしくお願いいたします。

在庫.xlsxはデスクトップにあります。

マクロが有るブックから、在庫.xlsxとRMI.xlsxを開いて操作
はい。そのようにしております。
（悲願） 2022/10/07(金) 11:37:06

 こんにちわ。＾＾。。。作ってはみましたが。
無駄な事をしているかもしれません。←何とか動いています。
処理内容が、ご希望の事案と合っているかご確認をお願いいたします。
紛争フォルダの退避後の、お試しをお勧めいたします。←必須かも。A＾＾；
きっともっと、スマートでより安全ななロジックが有る事と存じます。
[ご考察の際、何かの足しにでもなれば、幸甚です。でわ。m(__)m]
Option Explicit
Sub oNeInstance02()
    Const zNm         As String = "在庫.xlsx"
    Const rNm         As String = "RMI.xlsx"
    Dim i             As Long
    Dim lR            As Long
    Dim s             As Object
    Dim fS            As Object
    Dim rP            As String
    Dim zP            As String
    Dim zB            As Workbook
    Dim rB            As Workbook
    Dim tB            As Workbook
    Dim aSnm          As String
    Dim z()           As Variant
    Dim kn()          As Variant
    Dim r             As Range
    Dim cr            As Range
    Dim tr            As Range
    Set s = CreateObject("WScript.Shell")
    Set fS = CreateObject("Scripting.FileSystemObject")
    Set tB = ThisWorkbook
    rP = s.specialfolders("Desktop") & "\" & "紛争\"
    zP = s.specialfolders("Desktop") & "\"
    If Not fS.FileExists(rP & rNm) Then End
    If Not fS.FileExists(zP & zNm) Then End
    Set fS = Nothing
    Set zB = Workbooks.Open(zP & zNm)
    With zB.Worksheets("Sheet1")
        z = Intersect(.Cells(1).CurrentRegion, .Range("A:E")).Value
        .Range("G:G").Delete
        .Range("A:E").Delete
        Set r = .Cells(1).CurrentRegion
        kn = r.Offset(1).Resize(r.Rows.Count - 1).Value
    End With
    zB.Close False
    Set zB = Nothing
    Set r = Nothing
    Set rB = Workbooks.Open(rP & rNm)
    tB.Worksheets(1).Copy before:=tB.Worksheets(1)
    aSnm = tB.ActiveSheet.Name
    With Worksheets(aSnm)
        For i = LBound(kn) To UBound(kn)
            .UsedRange.Delete
            .Cells(1).Resize(UBound(z, 1), UBound(z, 2)) = z
            Set r = .Cells(1).CurrentRegion
            Set cr = .Cells(1, 10).Resize(2)
            cr(1) = r.Rows(1).Cells(5)
            cr(2) = kn(i, 1)
            r.AdvancedFilter xlFilterCopy, cr, .Cells(1, 12)
            cr.Clear
            .Range("A:K").Delete
            Set tr = .Cells(1).CurrentRegion
            Set tr = tr.Offset(1).Resize(tr.Rows.Count - 1, 3)
            With rB.Worksheets("Produt List")
                lR = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
                lR = IIf(lR < 6, 6, lR)
                Intersect(.Range("B:D"), .Range(.Rows(6), .Rows(lR))).Delete
                lR = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
                lR = IIf(lR < 6, 6, lR)
                .Cells(lR, 2).Resize(tr.Rows.Count, tr.Columns.Count) = tr.Value
            End With
            On Error Resume Next
                rB.SaveAs rP & kn(i, 2) & "_" & "RMI.xlsx", 51
            On Error GoTo 0
            If i Mod 8 = 0 Then DoEvents
        Next
        Application.DisplayAlerts = False
        .Delete
        Application.DisplayAlerts = True
    End With
    rB.Close False
    Erase z, kn
End Sub
（隠居Z） 2022/10/07(金) 12:45:02

（隠居Z）さん 2022/10/07(金) 12:45:02
ありがとうございます。

在庫.xlsxはデスクトップにあります。
RMI.xlsxは以下にあります。
C:\Users\USER\Desktop\紛争\RMI.xlsx
隠居Zさんのマクロはデスクトップにテスト.xlsmというブックを作り実行しています。
マクロ実行時、在庫.xlsxとRMI.xlsxは開いています。

以上の環境で上記マクロを実行すると
RangeクラスのDeleteメソッドが失敗しましたと表示されます。

Intersect(.Range("B:D"), .Range(.Rows(6), .Rows(lR))).Delete
この行が黄色く表示されます。
（悲願） 2022/10/07(金) 21:11:55

こんばんわ。＾＾

RMI.xlsx
ですが、書込みご指定のセル範囲も保護が
かけられている。という事は、御座いませんでしょうか。

（隠居Z） 2022/10/07(金) 21:37:40

↑、すみません、こちらの設定があまかったようです
別案を考えてみます。暫くお待ちくださいませ。

（隠居Z） 2022/10/07(金) 21:46:49

    With rB.Worksheets("Produt List")
        '.Protect UserInterfaceOnly:=True, Password:="****"
        lR = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
        lR = IIf(lR < 6, 6, lR)
        .Range("B6:D" & lR).Delete
        lR = 6
        .Cells(lR, 2).Resize(tr.Rows.Count, tr.Columns.Count) = tr.Value
    End With
に変更してみて、様子を見ていただけますか。＾＾；
m(_ _)m
（隠居Z） 2022/10/07(金) 22:06:41

（隠居Z）さん 2022/10/07(金) 22:06:41

ありがとうございます。
RMI.xlsxのProduct Listシートですが以下のようなレイアウトになっています。

          A      　　　　　　    B                　　　　　      C              　  　　　     D
 1 Completion required ～　A1からD1までセル結合さてれいる。保護されている
 2 A2からD2まで空白　保護されている　
 3 A3からD3まで空白　保護されている
 4 Click here to return to Declaration tab ←クリックするとDeclarationシート移動します。A4からD4までセル結合　保護なし
 5　　　　　　　Manufacturer's Product Number　　　Manufacturer's Product Number　　　　　　Comments　保護あり
 6　　　空白　　　　　　　　　入力欄　　　　　　　　　　　　　　入力欄　　　　　　　　　　　　　入力欄
 7　　　空白　　　　　　　　　入力欄　　　　　　　　　　　　　　入力欄　　　　　　　　　　　　　入力欄
2005行目まで入力欄があります。実際に入力するのは各仕入先ごと100行ほどです。

以上の環境で上記マクロを実行すると
RangeクラスのDeleteメソッドが失敗しましたと表示されます。

.Range("B6:D" & lR).Delete

ここが黄色く表示されます。
（悲願） 2022/10/08(土) 09:04:20

おはようございます。＾＾
以下に差し換えてみて下さいませ。
１．シート保護に際してパスワード設定をされていましたらご自身のパスワードに
　　書き換えて下さい。
２．在庫.xlsx　、RMI.xlsx　は開かずに実行してください。
３．どうしても事前に開いている可能性が有る場合[ファイル共有、他の人も同じファイルに
　　アクセスする等々]は、別途、様々な、対応が必要と思われます
　　例えば、他のフォルダの同名のファイルで中身が違う場合とか、
　　読み取り専用とか、排他制御、等々。。。ＥＴＣ
３．の場合は、私の環境ではテスト不可な為、他の回答者様のアドバイスをお待ちください。
　　A^^;。m(__)m
Option Explicit
Sub oNeInstance02()

    Const zNm         As String = "在庫.xlsx"
    Const rNm         As String = "RMI.xlsx"
    Dim i             As Long
    Dim lR            As Long
    Dim s             As Object
    Dim fS            As Object
    Dim rP            As String
    Dim zP            As String
    Dim zB            As Workbook
    Dim rB            As Workbook
    Dim tB            As Workbook
    Dim aSnm          As String
    Dim z()           As Variant
    Dim kn()          As Variant
    Dim r             As Range
    Dim cr            As Range
    Dim tr            As Range
    Set s = CreateObject("WScript.Shell")
    Set fS = CreateObject("Scripting.FileSystemObject")
    Set tB = ThisWorkbook
    rP = s.specialfolders("Desktop") & "\" & "紛争\"
    zP = s.specialfolders("Desktop") & "\"
    If fS.FileExists(rP & rNm) = False Or fS.FileExists(zP & zNm) = False Or _
        wBchk(zNm) Or wBchk(rNm) Then
        MsgBox "ファイルの二重起動、又は存在を確認してください"
        End
    End If
    Set fS = Nothing
    Set zB = Workbooks.Open(zP & zNm)
    With zB.Worksheets("Sheet1")
        z = Intersect(.Cells(1).CurrentRegion, .Range("A:E")).Value
        .Range("G:G").Delete
        .Range("A:E").Delete
        Set r = .Cells(1).CurrentRegion
        kn = r.Offset(1).Resize(r.Rows.Count - 1).Value
    End With
    zB.Close False
    Set zB = Nothing
    Set r = Nothing
    Set rB = Workbooks.Open(rP & rNm)
    tB.Worksheets(1).Copy before:=tB.Worksheets(1)
    aSnm = tB.ActiveSheet.Name
    With Worksheets(aSnm)
        For i = LBound(kn) To UBound(kn)
            .UsedRange.Delete
            .Cells(1).Resize(UBound(z, 1), UBound(z, 2)) = z
            Set r = .Cells(1).CurrentRegion
            Set cr = .Cells(1, 10).Resize(2)
            cr(1) = r.Rows(1).Cells(5)
            cr(2) = kn(i, 1)
            r.AdvancedFilter xlFilterCopy, cr, .Cells(1, 12)
            cr.Clear
            .Range("A:K").Delete
            Set tr = .Cells(1).CurrentRegion
            Set tr = tr.Offset(1).Resize(tr.Rows.Count - 1, 3)
            With rB.Worksheets("Produt List")
                .Unprotect Password:="****"
                lR = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
                lR = IIf(lR < 6, 6, lR)
                .Range("B6:D" & lR).Delete
                lR = 6
                .Cells(lR, 2).Resize(tr.Rows.Count, tr.Columns.Count) = tr.Value
                .Protect Password:="****"
            End With
            On Error Resume Next
                rB.SaveAs rP & kn(i, 2) & "_" & "RMI.xlsx", 51
            On Error GoTo 0
            If i Mod 8 = 0 Then DoEvents
        Next
        Application.DisplayAlerts = False
        .Delete
        Application.DisplayAlerts = True
    End With
    rB.Close False
    Erase z, kn
End Sub
Private Function wBchk(ByVal bNm As String) As Boolean
    Dim wB As Workbook
    wBchk = False
    For Each wB In Workbooks
        If wB.Name = bNm Then
            wBchk = True
            Exit For
        End If
    Next
End Function
（隠居Z） 2022/10/08(土) 09:56:27

隠居Zさん

まだ試せていませんが、マクロありがとうございます

1に関して
RMI.xlsxは公的機関から配布されているブックなので保護の解除は不可能です
パスワード解除は必須ですか？

2に関して
わかりました、開かず実行してみます

3に関して
個人のパソコンでの作業なので他人が在庫.xlsxとRMI.xlsxを開いているということはありません

マクロを試したら結果報告いたします
ありがとうございます
（悲願） 2022/10/08(土) 10:19:56

＞＞RMI.xlsxは公的機関から配布されているブックなので保護の解除は不可能です
１．Ｂ、Ｃ、Ｄの各列、6行目以降は入力欄で、手入力は出来るのですよね[ロック解除]

シート保護にパスワードが、かかっていなければ、上記コードでＯＫかもです
別案、考えます。←今から、お買い物。。。←パスすると、とんでもない目にあいそぉなので(*^^*)
昼からの対応で、ご容赦を。
パスワード、かかっていましたら、お手上げの可能性も。＾＾；。調べてみますね。
m(_ _)m
（隠居Z） 2022/10/08(土) 10:56:22

１．RMI_EMRT_1.02.xlsx　←　(ご紹介のサイトのテンプレートに有りました。)
　　のなかにも、"Product List"
　　というシートがありますが、RMI.xlsxの　Product List　と同じ内容でしょうか
　　入力可能セルの最下行が1000行までで
　　入力可能範囲が　B6:D1000　になっているものです。
２．別フォーマットだけど、同様に、入力可能範囲が限定範囲でしたら、最下行の
　　値を教えて下さい

（隠居Z） 2022/10/08(土) 13:09:08

すみません。
Delete
は乱暴でしたね。m(__)m
下記ではどうでしょう。だめでしたら
lR = IIf(lR > 1000, 1000, lR)　の1000を減らして見て下さい。
といいますか、最大手入力可能行数としてみて下さいませ。m(__)m

 Option Explicit
Sub oNeInstance02()
    Const zNm         As String = "在庫.xlsx"
    Const rNm         As String = "RMI.xlsx"
    Dim i             As Long
    Dim lR            As Long
    Dim s             As Object
    Dim fS            As Object
    Dim rP            As String
    Dim zP            As String
    Dim zB            As Workbook
    Dim rB            As Workbook
    Dim tB            As Workbook
    Dim aSnm          As String
    Dim z()           As Variant
    Dim kn()          As Variant
    Dim r             As Range
    Dim cr            As Range
    Dim tr            As Range
    Set s = CreateObject("WScript.Shell")
    Set fS = CreateObject("Scripting.FileSystemObject")
    Set tB = ThisWorkbook
    rP = s.specialfolders("Desktop") & "\" & "紛争\"
    zP = s.specialfolders("Desktop") & "\"
    If fS.FileExists(rP & rNm) = False Or fS.FileExists(zP & zNm) = False Or _
        wBchk(zNm) Or wBchk(rNm) Then
        MsgBox "ファイルの二重起動、又は存在を確認してください"
        End
    End If
    Set fS = Nothing
    Set zB = Workbooks.Open(zP & zNm)
    With zB.Worksheets("Sheet1")
        z = Intersect(.Cells(1).CurrentRegion, .Range("A:E")).Value
        .Range("G:G").Delete
        .Range("A:E").Delete
        Set r = .Cells(1).CurrentRegion
        kn = r.Offset(1).Resize(r.Rows.Count - 1).Value
    End With
    zB.Close False
    Set zB = Nothing
    Set r = Nothing
    Set rB = Workbooks.Open(rP & rNm)
    tB.Worksheets(1).Copy before:=tB.Worksheets(1)
    aSnm = tB.ActiveSheet.Name
    With Worksheets(aSnm)
        For i = LBound(kn) To UBound(kn)
            .UsedRange.Delete
            .Cells(1).Resize(UBound(z, 1), UBound(z, 2)) = z
            Set r = .Cells(1).CurrentRegion
            Set cr = .Cells(1, 10).Resize(2)
            cr(1) = r.Rows(1).Cells(5)
            cr(2) = kn(i, 1)
            r.AdvancedFilter xlFilterCopy, cr, .Cells(1, 12)
            cr.Clear
            .Range("A:K").Delete
            Set tr = .Cells(1).CurrentRegion
            Set tr = tr.Offset(1).Resize(tr.Rows.Count - 1, 3)
            With rB.Worksheets("Produt List")
                lR = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
                lR = IIf(lR < 6, 6, lR)
                lR = IIf(lR > 1000, 1000, lR)
                .Range("B6:D" & lR).ClearContents
                lR = 6
                .Cells(lR, 2).Resize(tr.Rows.Count, tr.Columns.Count) = tr.Value
            End With
            On Error Resume Next
                rB.SaveAs rP & kn(i, 2) & "_" & "RMI.xlsx", 51
            On Error GoTo 0
            If i Mod 8 = 0 Then DoEvents
        Next
        Application.DisplayAlerts = False
        .Delete
        Application.DisplayAlerts = True
    End With
    rB.Close False
    Erase z, kn
End Sub
Private Function wBchk(ByVal bNm As String) As Boolean
    Dim wB As Workbook
    wBchk = False
    For Each wB In Workbooks
        If wB.Name = bNm Then
            wBchk = True
            Exit For
        End If
    Next
End Function
（隠居Z） 2022/10/08(土) 14:00:22

（隠居Z）さん 2022/10/08(土) 13:09:08
に返信したつもりで、更新し忘れていたようです。
申し訳ありません。

（隠居Z） 2022/10/08(土) 14:00:22
のマクロはまだ試していませんが、本日17時までには試します。

（隠居Z）さん 2022/10/08(土) 13:09:08
への返信は以下の通りです。あとさきになってしまい申し訳ありません。

1に関して
というシートがありますが、RMI.xlsxの　Product List　と同じ内容でしょうか
はい、同じです。

2に関して
CMRTとEMRTという2つのフォーマットがあります。
この2つのフォーマットはシートの並び、シートの名前、Product Listの保護の範囲が同じで、違うのはProduct Listの最終行です。あとはRevisionシートの文言、Instrctionsの文言が違うくらいです。（ここはマクロには関係のない部分だと思います。）

CMRT　入力可能セルの最下行が2005行まで　入力可能範囲が　B6:D2005
EMRT　入力可能セルの最下行が1000行まで　入力可能範囲が　B6:D1000
となっています。
（悲願） 2022/10/08(土) 15:50:35

（隠居Z）さん 2022/10/08(土) 14:00:22
ありがとうございます。
仕入れ先ごと分類できました。
可能でしたら、【管理No】仕入先名-（Const rNm As String = "RMI.xlsx"の""の中のブック名）.xlsx
Const rNm As String = "RMI_EMRT_1.02.xlsx"
なら
【管理No】仕入先名-RMI_EMRT_1.02.xlsxになれば完璧です。

このあたりはリネームソフトを使えばいい話なのですが。

長々とお付き合いいただきありがとうございました。
感謝の言葉の申し上げようもありません。
ありがとうございました。
（悲願） 2022/10/08(土) 16:26:40

恐縮で御座います。楽しく勉強させて戴きました。m(__)m
On Error Resume Next
　　ここの箇所を下記に変更すればブック名が変わりますです。　
On Error GoTo 0

 On Error Resume Next
    rB.SaveAs rP & "【" & kn(i, 2) & "】" & kn(i, 1) & "-" & "RMI.xlsx", 51
On Error GoTo 0

尚、書込み件数が995件以上になればエラーになります。
後ほど、この部分のみ、回避[情報を書き込まず、メッセージだけ出して次の処理に移行]
処理を、追加いたしておきますので。暫くしてから、又のぞいてみて下さい。
多分、そんなにたくさん、書込むことはまず、無いのでしょうね。＾＾；
m(__)m
（隠居Z） 2022/10/08(土) 17:33:14

 1.気になっていたのですが、"RMI.xlsx"　の処理対象シート名ですが
 Produt List を　
 Product List に変更いたしました。
いらぬお世話でしたら、書き戻しをお願いいたします。＾＾；
他、エラー処理、便利機能は、ございませんが、ご了承くださいませ。
でわ、これにて失礼致します。m(__)m
Option Explicit
Sub oNeInstance02()
    Const zNm         As String = "在庫.xlsx"
    Const rNm         As String = "RMI.xlsx"
    Dim i             As Long
    Dim lR            As Long
    Dim s             As Object
    Dim fS            As Object
    Dim rP            As String
    Dim zP            As String
    Dim zB            As Workbook
    Dim rB            As Workbook
    Dim tB            As Workbook
    Dim aSnm          As String
    Dim z()           As Variant
    Dim kn()          As Variant
    Dim r             As Range
    Dim cr            As Range
    Dim tr            As Range
    Set s = CreateObject("WScript.Shell")
    Set fS = CreateObject("Scripting.FileSystemObject")
    Set tB = ThisWorkbook
    rP = s.specialfolders("Desktop") & "\" & "紛争\"
    zP = s.specialfolders("Desktop") & "\"
    If fS.FileExists(rP & rNm) = False Or fS.FileExists(zP & zNm) = False Or _
        wBchk(zNm) Or wBchk(rNm) Then
        MsgBox "ファイルの二重起動、又は存在を確認してください"
        End
    End If
    Set fS = Nothing
    Set zB = Workbooks.Open(zP & zNm)
    With zB.Worksheets("Sheet1")
        z = Intersect(.Cells(1).CurrentRegion, .Range("A:E")).Value
        .Range("G:G").Delete
        .Range("A:E").Delete
        Set r = .Cells(1).CurrentRegion
        kn = r.Offset(1).Resize(r.Rows.Count - 1).Value
    End With
    zB.Close False
    Set zB = Nothing
    Set r = Nothing
    Set rB = Workbooks.Open(rP & rNm)
    tB.Worksheets(1).Copy before:=tB.Worksheets(1)
    aSnm = tB.ActiveSheet.Name
    With Worksheets(aSnm)
        For i = LBound(kn) To UBound(kn)
            .UsedRange.Delete
            .Cells(1).Resize(UBound(z, 1), UBound(z, 2)) = z
            Set r = .Cells(1).CurrentRegion
            Set cr = .Cells(1, 10).Resize(2)
            cr(1) = r.Rows(1).Cells(5)
            cr(2) = kn(i, 1)
            r.AdvancedFilter xlFilterCopy, cr, .Cells(1, 12)
            cr.Clear
            .Range("A:K").Delete
            Set tr = .Cells(1).CurrentRegion
            Set tr = tr.Offset(1).Resize(tr.Rows.Count - 1, 3)
            If tr.Rows.Count <= (1000 - 6 + 1) Then
                With rB.Worksheets("Product List")
                    lR = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
                    lR = IIf(lR < 6, 6, lR)
                    lR = IIf(lR > 1000, 1000, lR)
                    .Range("B6:D" & lR).ClearContents
                    lR = 6
                    .Cells(lR, 2).Resize(tr.Rows.Count, tr.Columns.Count) = tr.Value
                End With
                On Error Resume Next
                    rB.SaveAs rP & "【" & kn(i, 2) & "】" & kn(i, 1) & "-" & "RMI.xlsx", 51
                On Error GoTo 0
            Else
                MsgBox "【 " & kn(i, 2) & " 】" & kn(i, 1) & Chr(13) & _
                "は件数オバーの為書込み出来ませんでした。"
            End If
            If i Mod 8 = 0 Then DoEvents
        Next
        Application.DisplayAlerts = False
        .Delete
        Application.DisplayAlerts = True
    End With
    rB.Close False
    Erase z, kn
End Sub
Private Function wBchk(ByVal bNm As String) As Boolean
    Dim wB As Workbook
    wBchk = False
    For Each wB In Workbooks
        If wB.Name = bNm Then
            wBchk = True
            Exit For
        End If
    Next
End Function
（隠居Z） 2022/10/08(土) 21:09:44

（隠居Z）さん 2022/10/08(土) 21:09:44

ありがとうございます。
理想の動作です。悲願成就。
長々とお付き合いいただきありがとうございました。
重ね重ねになりますが、感謝の言葉の申し上げようもありません。

また、コメントをくださった
もこな２さん、無料依頼所ではないさん、マナさん、半平太さん、感謝申し上げます。
（悲願） 2022/10/10(月) 08:50:30

話が終わったようなのでコメントします。結局どこで詰まっていたのでしょうか？

★１　当初のパターン
　

 【在庫.xlsx の Sheet1】
       A       B         C       D
 1   図版     形式　　　部署    管理No
 2    ASD     QWE       製造     s-2
 3    SDF     QRT       製造     s-2
 4    FGH     OOP       品質     s-4
 5    VFG     SND       購買     s-1
 6    BGH     ALP       総務     s-3
 7    ZXC     QER       総務     s-3
 8    CVD     RIR       品質     s-4
 9    ASW     NNK       購買     s-1

↓

 【【s-2】製造.xlsx の Sheet1】
       A       B         C       D
 1   図版     形式　　　部署    管理No
 2    ASD     QWE       製造     s-2
 3    SDF     QRT       製造     s-2

 【【s-4】品質.xlsx の Sheet1】
       A       B         C       D
 1   図版     形式　　　部署    管理No
 3    FGH     OOP       品質     s-4
 3    CVD     RIR       品質     s-4

 ◆マナさんの2022/10/02(日) 18:53 の動き
 (01)【在庫.xlsx の Sheet1】をコピーしてブックを作成
 (02)デスクトップの「管理」フォルダを取得する
 (03)フィルタオプションを使って【重複のないリスト】を得る

 (04)リストから【ファイル名】を組み立てる
 (05)フィルタオプションを使って(1)から必要のないデータをクリアする
 (06)↑を(4)の名前で(2)に保存する
 (06)(3)のリストから処理の終わったものを削除する
 (07)次の処理へ

 ◆私の2022/10/05(水) 12:02の動き
 (01)作業用のシートを【在庫.xlsx】に作成する
 (02)【在庫.xlsx の Sheet1】にオートフィルタを設定する
 (03)オートフィルタの設定した範囲のC～D列を(1)にコピーする
 (04)↑を重複の削除を使って【重複のないリスト】を得る

 (05)リスト（の１番目）から【ファイル名】を組み立てる
 (06)リスト（の１番目）を条件にオートフィルタでデータを抽出する
 (07)抽出されたデータを見出し行ごとコピーして新規ブックの１番目のシートへコピーする
 (08)【在庫.xlsx】と同じフォルダに(4)のファイル名で(6)で作成されたブックを保存する
 (09)↑を閉じる
 (10)次の処理（リストの２番目）へ

★２　「2022/10/04(火) 23:32」のパターン

 　　　A　　　　　　　　　　B　　　　　C　　　　　　　D　　　　　　E　　　　　　F　　　　　　　　　  G      　　H
 1　　パーツコード　　　　型番　　　　客先型番　　　メーカー　　　仕入先　　　　仕入先（重複なし）　       　管理NO
 2　　123                AAA            ZZZ           A             A商事　　　　A商事　　　　　　　　      　S-01
 3    410                BBB            UUU           B             C商事　　　　B商事　　　　　　　　      　S-02
 4    789                CCC            YYY           C             A商事　　　　C商事　　　　　　　　      　S-03
 5    467                DDD            KKK           D             B商事

 ◆半平太さん 2022/10/05(水) 09:31の動き
 (01)【在庫.xlsx の Sheet1】のシートをコピーして作業用のシートを（別ブックに）作成する
 (02)↑をE列をキーにして並び替える
 (03)ループ処理でどの行からどの行までがコピー対象となるのか調べる
 (04)項目行と↑で特定した行をコピーして、新規ブックに貼り付けする
 (05)（01）のF列、H列から【ファイル名】を組み立てる
 (06)（04）で作成されたブックを↑の名前で保存する
 (07) 次の処理へ

結局やめてしまったようですが、ステップ実行すればこれらは理解できたでしょう。
どの方法も、多少レイアウトが変わっても応用は容易だと思いますが、どの辺がわからなかったのでしょうか？
今後の説明の仕方の参考にしたいので是非とも教えていただきたいです。

（もこな２） 2022/10/10(月) 10:45:25

コメント返信：

[ 一覧(最新更新順) ]

[[20221001175637]] 『オートフィルタの結果ごと特定の名前をつけて別ブ』（悲願） ページの最後に飛ぶ

[[20221001175637]]　『オートフィルタの結果ごと特定の名前をつけて別ブ』（悲願）　ページの最後に飛ぶ