マクロについて質問です。

質問

A B C　　
1 3 りんご
2　　赤
3　くだもの
4 6　みかん
5　オレンジ
6　くだもの
7 9 ぶどう
8　　紫
9　くだもの
というデータがシート1にあったとして、シート2のa2セルに6と入力すると以下のようにa5セル以降に抽出し、6という入力を消すと抽出したものも消えるようなマクロ
6 みかん
　オレンジ
　くだもの
上のような質問で下のマクロを教えていただけたのですが、もし、みかんのb列も3だった場合いしたのようにみかんの行まで抽出できるようにするには下の構文をどうかえたらよいでしょうか。下手くそな質問ですがよろしくお願いします。
3 りんご
　　赤
　くだもの
　みかん
　オレンジ
　くだもの

現在、わかっている構文↓
Private Sub Worksheet_Change(ByVal Target As Range) 'この行から
Dim c As Range, wS As Worksheet
Set wS = Worksheets("Sheet1")
With Target
If .Address = "$A$2" Then
If .Value <> "" Then
Set c = wS.Range("B:B").Find(what:=.Value, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
c.Offset(, 1).Resize(3).Copy Range("A5")
Else
MsgBox "該当データなし"
End If
Else
Range("A5").Resize(3).ClearContents
End If
End If
End With
End Sub 'この行まで

回答No.3

tom04 · ベストアンサー

No.2の補足
＞A列の連番がない状態で同じようにできるのでしょうか。
いままではA列は最終行を取得するためだけに使っていましたので、
A列データがあってもなかっても対応するために、C列で最終行を取得してみました。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, c As Range, lastRow As Long, wS As Worksheet
Set wS = Worksheets("Sheet1")
With Target
If .Address = "$A$2" Then
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
If lastRow > 4 Then
Range(Cells(5, "A"), Cells(lastRow, "E")).ClearContents '←列番号を修正
End If
Set c = wS.Range("B:B").Find(what:=.Value, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
For i = 1 To wS.Cells(Rows.Count, "C").End(xlUp).Row Step 3 '★←C列で最終行取得
If wS.Cells(i, "B") = .Value Then
wS.Cells(i, "C").Resize(3, 3).Copy Cells(Rows.Count, "A").End(xlUp).Offset(1) '←Resizeで列も追加
End If
Next i
Else
MsgBox "該当データなし"
.Select
.Value = ""
End If
End If
End With
End Sub

※　これでどうでしょうか？m(_ _)m

お礼

助かりました！
ありがとうございます。

回答No.2

tom04

No.1です。

＞項目の入った列がcからeだとしたらどこを変更するとよいですか
とは、↓の画像のように元データのC～E列を表示すれば良いのでしょうか？
その場合は↓のコードにしてみてください。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, c As Range, lastRow As Long, wS As Worksheet
Set wS = Worksheets("Sheet1")
With Target
If .Address = "$A$2" Then
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
If lastRow > 4 Then
Range(Cells(5, "A"), Cells(lastRow, "E")).ClearContents '←列番号を修正
End If
Set c = wS.Range("B:B").Find(what:=.Value, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
For i = 1 To wS.Cells(Rows.Count, "A").End(xlUp).Row Step 3
If wS.Cells(i, "B") = .Value Then
wS.Cells(i, "C").Resize(3, 3).Copy Cells(Rows.Count, "A").End(xlUp).Offset(1) '←Resizeで列も追加
End If
Next i
Else
MsgBox "該当データなし"
.Select
.Value = ""
End If
End If
End With
End Sub

※　表のレイアウトが判ればもっと具体的なアドバイスができると思います。m(_ _)m

補足

何度も何度も回答いただきありがとうございます。最後の補足なのですが、A列の連番がない状態で同じようにできるのでしょうか。

回答No.1

tom04

こんばんは！

↓の画像のように左側がSheet1・右側がSheet2とします。
Sheet1は3行毎にデータがあるとします。
尚、Sheet2のA4セルには「ストッパー」代わりに項目名なり何らかのデータを入れておいてください。

Sheet2のシートモジュールです。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, c As Range, lastRow As Long, wS As Worksheet
Set wS = Worksheets("Sheet1")
With Target
If .Address = "$A$2" Then
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
If lastRow > 4 Then
Range(Cells(5, "A"), Cells(lastRow, "A")).ClearContents
End If
Set c = wS.Range("B:B").Find(what:=.Value, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
For i = 1 To wS.Cells(Rows.Count, "A").End(xlUp).Row Step 3
If wS.Cells(i, "B") = .Value Then
wS.Cells(i, "C").Resize(3).Copy Cells(Rows.Count, "A").End(xlUp).Offset(1)
End If
Next i
Else
MsgBox "該当データなし"
.Select
.Value = ""
End If
End If
End With
End Sub

こんな感じではどうでしょうか？m(_ _)m

補足

回答ありがとうございます。項目の入った列がcからeだとしたらどこを変更するとよいですか。