フィルター後にマクロ実行でシート分割とソートを実装

質問

ExcelのVBAについて、お知恵のある方のご見識をいただきたく質問させていただきました。

添付ファイルのように、[仕入先]というシートで、[商材カテゴリ]を「食品」と選択した後に、マクロ実行させることで下記内容を実装するためには、どのようなコードが必要となるでしょうか？

【マクロの機能】
①仕入先別にシートが作成される。
②[予定納期]を昇順にして、[項番]、（シート名の）[仕入先]、[商材カテゴリ]、[商品]、[予定納期]が各シートに転記される。

たったこれだけのマクロ機能なのですが、恥ずかしながら色々と調べても解らなかったため、質問してみました。どうぞ、よろしくお願いいたします。

回答No.3

SI299792

であれば、私のプログラムでできます。
やってみて下さい。

回答No.2

HohoPapa

こんな感じでしょうか。

なお、手作業でフィルターを設定する前に
仕入先順、予定納期昇順に並べてあれば
コードがよりシンプルになり、
（コードを修正することで）
動作スピードも上がると思います。

Option Explicit

Sub sample()

　Dim LastRow As Long '最終行番号
　Dim FSh As Worksheet　'転記元シート
　Dim i As Long
　Dim s As Long
　Dim HitFlg As Boolean　'転記先シート発見フラグ
　Dim ShName As String　'転記先シート名
　Dim tgRow As Long　　'転記先行番号

　Set FSh = ThisWorkbook.Sheets("仕入先")

　LastRow = FSh.Cells(Rows.Count, 2).End(xlUp).Row

　For i = 2 To LastRow
　　If Not FSh.Rows(i).Hidden Then

　　　ShName = FSh.Cells(i, 2).Value
　　　HitFlg = False

　　　For s = 1 To ThisWorkbook.Sheets.Count
　　　　If Worksheets(s).Name = ShName Then
　　　　　HitFlg = True
　　　　　Exit For
　　　　End If
　　　Next s

　　　If HitFlg = False Then
　　　　Sheets.Add After:=Worksheets(ThisWorkbook.Sheets.Count)
　　　　Worksheets(ThisWorkbook.Sheets.Count).Name = ShName
　　　　Worksheets(ShName).Rows(1).Value = FSh.Rows(1).Value
　　　End If

　　　tgRow = Worksheets(ShName).Cells(Rows.Count, 2).End(xlUp).Row + 1
　　　Worksheets(ShName).Rows(tgRow).Value = FSh.Rows(i).Value

　　End If
　Next i

　For s = 2 To ThisWorkbook.Sheets.Count
　　LastRow = Worksheets(s).Cells(Rows.Count, 2).End(xlUp).Row
　　With Worksheets(s).Sort
　　　.SortFields.Clear
　　　.SortFields.Add2 Key:=Range("E:E"), _
　　　　SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
　　　.SetRange Range("A1:Z" & LastRow)
　　　.Header = xlYes
　　　.MatchCase = False
　　　.Orientation = xlTopToBottom
　　　.SortMethod = xlPinYin
　　　.Apply
　　End With
　Next s

End Sub

回答No.1

SI299792

この図ではセル位置が解りません。
左上がA1で１行が項目名、２行以下がデータとします。
Ｅ列は数字で、表示形式、ユーザー定義 ｢0"日"｣にしてあるものとします。
「仕入先」シート以右をクリアして実行しています。
もし、消したくないシートがあれば、「仕入先」シート以左に配置して下さい。
Option Explicit
'
Sub Macro1()
　　Dim I As Worksheet
　　Dim Cell As Range
　　Dim Sheet As Variant
　　Dim REnd As Long
'
　　Set I = Sheets("仕入先")
　　Set Cell = I.Cells(Rows.Count, "A").End(xlUp)
　　Application.ScreenUpdating = False
'
　　For Sheet = I.Index + 1 To Sheets.Count
　　　　Sheets(Sheet).Range("A2:E" & Rows.Count).ClearContents
　　Next Sheet
'
　　For Each Cell In I.Range("A2", Cell).SpecialCells(xlCellTypeVisible)
　　　　Sheet = Cell.Offset(, 1)
　　　　On Error GoTo 100
　　　　Sheets(Sheet).Select
　　　　On Error GoTo 0
　　　　REnd = Cells(Rows.Count, "A").End(xlUp).Row
　　　　[A1:E1].Offset(REnd) = Cell.Resize(, 5).Value
　　Next Cell
'
　　For Sheet = I.Index + 1 To Sheets.Count
　　　　Sheets(Sheet).Select
　　　　REnd = Cells(Rows.Count, "A").End(xlUp).Row
　　　　Range("A2:E" & REnd).Sort Key1:=[E2]
　　Next Sheet
　　End
'
100 '
　　If Err <> 9 Then
　　　　Error Err
　　End If
　　Sheets.Add After:=Sheets(Sheets.Count)
　　ActiveSheet.Name = Sheet
　　[A1:E1] = I.[A1:E1].Value
　　[E:E].NumberFormatLocal = "0""日"""
　　Resume
End Sub

補足

ご回答ありがとうございます。セル位置を記載しておらず、大変失礼いたしました。仮定されたように、1行目が項目で、2行目以下がデータという前提です。そして、元ファイルは「仕入先」のシートしか存在せず、マクロ実行により仕入先ごとにシートが増え、当該増えた仕入先ごとのシートに、日付が昇順で項目が増えるような機能を想定しております。