条件に一致した場合の処理

「メニュー」シートの家族名と「材料」シートの家族名が一致した場合、
新たにシートを作成しA1には「メニュー」シートのA列の家族名を
2行目以降には「材料」シートのF～J列を整理番号の昇順で貼り付け
シートの名前は「メニュー」シートのメニュー名にしたいです。
メニュー名が他のシートと重複した場合、メニュー名に（1）（2）などをつけて
区別させたいです。

お詳しい方宜しくお願いいたします。

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

• ご質問ありがとうございます。振り分けた後はそのまま保存しますので、再度実行は考えてはいませんが、そのまま上書きされると良いです。
  宜しくお願い致します。

  No.1の回答に寄せられた補足コメントです。 補足日時：2022/10/18 10:49

No.2 ベストアンサー 回答者： fujillin 回答日時： 2022/10/19 15:31

こんにちは

回答が無いようですので・・・

内容的に多少複雑ですが、ご質問文にない不明点は勝手に解釈してあります。
違っている部分があれば、適当に修正してください。

※ 結合セルの存在は考慮していません。（無いものと仮定）

Sub Q_13192436()
Dim menu As Worksheet, mtrl As Worksheet, sh As Worksheet
Dim MRmenu As Long, MRmtrl As Long, mn As String
Dim r As Range, i As Long, n As Long

Set menu = shtChk("メニュー")
Set mtrl = shtChk("材料")
If menu Is Nothing Or mtrl Is Nothing Then
MsgBox "必要なシートがありません"
Exit Sub
End If

mtrl.Cells(1, 1).AutoFilter
MRmenu = menu.Cells(Rows.Count, 1).End(xlUp).Row
MRmtrl = mtrl.Cells(Rows.Count, 1).End(xlUp).Row
If MRmenu < 2 Or MRmtrl < 2 Then Exit Sub
Set r = mtrl.Cells(1, 1).Resize(MRmtrl, 10)

Application.ScreenUpdating = False
For i = 2 To MRmenu
mn = menu.Cells(i, 2).Text
If menu.Cells(i, 1) <> "" And mn <> "" Then
n = WorksheetFunction.CountIf(menu.Cells(2, 2).Resize(i - 1), mn)
If n > 1 Then mn = mn & "(" & n & ")"
Set sh = shtChk(mn)
If sh Is Nothing Then
Set sh = Worksheets.Add(after:=Worksheets(Worksheets.Count))
sh.Name = mn
End If

sh.Columns("A:E").Clear
sh.Cells(1, 1).Value = menu.Cells(i, 1).Value
r.AutoFilter Field:=1, Criteria1:=menu.Cells(i, 1).Text
r.Columns("F:J").Copy sh.Cells(2, 1)
r.AutoFilter
n = sh.Cells(Rows.Count, 1).End(xlUp).Row
If n > 3 Then sh.Cells(2, 1).Resize(n, 5).Sort Key1:=sh.Cells(2, 1), Header:=xlYes
End If
Next i
Application.ScreenUpdating = True
End Sub

Function shtChk(ByVal n As String) As Worksheet
Dim sh As Worksheet
For Each sh In Worksheets
If sh.Name = n Then Set shtChk = sh: Exit For
Next sh
End Function

この回答へのお礼

ありがとうございます！
完璧です！

お礼日時：2022/10/20 12:09

No.1 回答者： めぐみん_ 回答日時： 2022/10/18 09:20

振り分けた後、また実行する事があるとしたらそれぞれのシートと振り分けはどのようになるのでしょう？