VBA オートフィルタの使い方について

質問

VBAのオートフィルタの使い方について
教えていただきたい部分がございます。
画像について
①～④までの果物、個数、値段を別のシートにコピーしたいと思っています。
それまではできるのですが、
⑤個目の果物が増えたりした場合も自動的にコピーして
別シートに貼り付けれるようにしたいと思っています。

①でフィルタして、コピーして、貼り付けて
次は②でフィルタして、コピーして貼り付けてを繰り返すのに
⑤個目が増えたり、④がなくなった場合でも
ある分だけをコピーして貼り付けれるようにしたいです。
一つずつ
Selection.AutoFilter Field:=1, Criteria1:="①"
みたいな感じでやらずに①～ある分だけフィルタをかけるみたいなやり方はないでしょうか。
説明がわかりずらくて、申し訳ございません。
回答をよろしくお願いいたします。

回答No.3

SI299792

Option Explicit
'
Sub Macro1()
　　Dim I As Worksheet
　　Dim REnd As Long
　　Dim RInp As Long
　　Dim ROut As Long
　　Dim SheetName As String
'
　　Set I = Sheets("Sheet1")
　　REnd = I.Cells(Rows.Count, "B").End(xlUp).Row
　　I.AutoFilterMode = False
　　Application.ScreenUpdating = False
'
　　For RInp = 3 To REnd
　　　　SheetName = I.Cells(RInp, "B")
'
　　　　If RInp = Application.Match(SheetName, I.[B:B], 0) Then
　　　　　　On Error GoTo 100
　　　　　　Sheets(SheetName).Select
　　　　　　On Error GoTo 0
　　　　　　Cells.Clear
　　　　　　I.Range("B2:E" & REnd).AutoFilter 1, SheetName
　　　　　　I.Range("B2:E" & REnd).Copy [B2]
　　　　End If
　　Next RInp
　　I.AutoFilterMode = False
　　End
100 '
　　Sheets.Add After:=Sheets(Sheets.Count)
　　ActiveSheet.Name = SheetName
　　Resume Next
End Sub

回答No.2

imogasi

既に解答は出たが、それでOKですか。
そうでないなら、下記文章を参考にして読んで、質問の、「したいこと」を（文章で！！動的なことらしいから、画像は不適と思う。）説明したほうが良いのでは。
全般に、質問の意味が良く判らなかった．
（１）メイン課題はオートフィルタ（VBA）を使って、C列で「指定した果物」の行を、別シートに、（商品（＝果物）ごとだと思うが、別シートか、別区画か）分けて作るのか？
（２）その後、データの増加（行増加）があれば、質問者のVBA実行操作はなくても、自動で（１）のオートフィルタをしたいのか？
そのさい、一旦ShowAllDataをして、作業を一からやっても良いのか？
　結果データを、作り替え（一旦抹消ー再作成）でもいいのか？
＝＝
行増加を捉えるやり方の記事は、Googleで「エクセル　event　行追加　を捉える」などで照会すると出てくるが、あまりスマートな方法ではない。
「エクセルマクロ】行挿入・行削除を検知：イベント」
https://kirinote.com/excelvba-row-event/
　もし上記のことなら、余り質問に出ない課題のように思った。
本来、データ変化の自動反映は、望ましいことだが、仕組みとして、難しいことではないか。

回答No.1

kkkkkm

以下の方法で試してみてください。

Sub TestDic()
Dim LastRow As Long, i As Long
Dim C_List As Object
Dim C_Value As Variant

Set C_List = CreateObject("Scripting.Dictionary")

LastRow = Cells(Rows.Count, "B").End(xlUp).Row

For i = 3 To LastRow
If C_List.exists(Cells(i, "B").Value) = False Then
C_List.Add Cells(i, "B").Value, Cells(i, "B").Value
End If
Next

For Each C_Value In C_List
Range(Cells(2, "B"), Cells(LastRow, "E")).AutoFilter Field:=1, Criteria1:=C_Value
MsgBox C_Value
Next

Set C_List = Nothing

End Sub

MsgBox CValue
のところをコピーのコードに変更してください。

あと作業列を使ってコードを簡単にする場合

A列が開いているので仮にA列を使うとして
A3に
=IF(COUNTIF($B$3:B3,B3)=1,B3,"")
として必要なだけ下にコピーします。

VBAで以下のようにして
MsgBox Cells(i, "A").Value
のところをコピーのコードに変更してください。

Sub Test()
Dim LastRow As Long, i As Long

LastRow = Cells(Rows.Count, "B").End(xlUp).Row

For i = 3 To LastRow
If Cells(i, "A").Value <> "" Then
Range(Cells(2, "B"), Cells(LastRow, "E")).AutoFilter Field:=1, Criteria1:=Cells(i, "A").Value
MsgBox Cells(i, "A").Value
End If
Next
End Sub