ExcelvbaのFindNext複数項目繰り返し

質問

Excelvba2013で、同じ検索条件で続けて検索取得していくのに、ネットで調べながらFindNextを使ってやっています。

"テーブル"シートのA列に検索したい分類項目が記載されていて、その隣のB列にデータがあります。分類項目は変動するため数は不明です。
そして、"データ"シートのC3,D3,E3・・・と分類項目が載っています。
Ｃ３の下のC4,C5,C6・・・に分類項目のC3のデータを入れていき、Ｄ3の下のD4,D5,D6・・・にD4のデータ、以降E列、F列と続いていきます。

とりあえず、現在、"データ"シートのC3の項目に対するデータは取得できています。以降、C3の項目のデータが満たされたらD3、E3・・・と"テーブル"シートのA列の分類項目をすべて満たすまで繰り返したいのですが、繰り返し処理のやり方がうまくできず、次の分類項目に進めずにいます。

以下のコードをどのように変えたらよいでしょうか？
すいません、いつもお手数をおかけしています。

Sub 同じ条件でデータ検索繰り返し2()

Dim myRange As Range, srcRange As Range, myAddress As String, i As Integer, p As Integer

Application.ScreenUpdating = False

p = 3
Set srcRange = Worksheets("テーブル").Range("A:A") 'テーブルのA列を格納

Set myRange = srcRange.Find(What:=Worksheets("データ").Cells(3, p).Value, LookIn:=xlValues, _
LookAt:=xlWhole) If Not myRange Is Nothing Then
myAddress = myRange.Address
i = 4
Do

Cells(i, p).Value = myRange.Offset(, 1).Value
Set myRange = srcRange.FindNext(After:=myRange)
i = i + 1
Loop Until myRange.Address = myAddress
End If
If myRange.Address = myAddress Then

Do
p = p + 1
Cells(i, p).Value = myRange.Offset(, 1).Value
Set myRange = srcRange.FindNext(After:=myRange)
i = i + 1

Loop Until myRange.Address = myAddress
Else
End If

End Sub

回答No.1

watabe007 · ベストアンサー

参考に
Sub 同じ条件でデータ検索繰り返し3()
　　Dim myRange As Range, srcRange As Range, myAddress As String, i As Long
　　Dim c As Range

　　Application.ScreenUpdating = False
　　Set srcRange = Worksheets("テーブル").Range("A:A") 'テーブルのA列を格納
　　For Each c In Worksheets("データ").Range("C3:E3") '"データ"シートのC3,D3,E3・
　　　　Set myRange = srcRange.Find(What:=c.Value, LookIn:=xlValues, LookAt:=xlWhole)
　　　　If Not myRange Is Nothing Then
　　　　　　myAddress = myRange.Address
　　　　　　i = 1
　　　　　　Do
　　　　　　　　c.Offset(i).Value = myRange.Offset(, 1).Value
　　　　　　　　Set myRange = srcRange.FindNext(After:=myRange)
　　　　　　　　i = i + 1
　　　　　　Loop Until myRange.Address = myAddress
　　　　End If
　　Next
　　Application.ScreenUpdating = True
End Sub

お礼

早速ありがとうございます。
動作は問題ありませんでした。
ただRange("C3:E3") と直接指定しているのでデータの分類項目が増えたとき変更が必要になるので他の人が使う時に反映されないよ、ということが起こりそうです。最初に余裕をみとくと、処理に無駄に時間がかかりました。
そこでデータの分類項目を数えて、それを変数でいれてやると、かなりよくなりました。それでも1分くらいかかりますが・・・。
どうもありがとうございました。

Sub 同じ条件でデータ検索繰り返し4()
Dim myRange As Range, srcRange As Range, myAddress As String, i As Long, p As Long
Dim c As Range

Application.ScreenUpdating = False

'フィルター解除
If Worksheets("テーブル").FilterMode Then
Worksheets("テーブル").ShowAllData
End If

Set srcRange = Worksheets("テーブル").Range("A:A") 'テーブルのA列を格納
p = Range("B4:B" & Cells(Rows.Count, "B").End(xlUp).Row).Count
For p = 3 To p
For Each c In Worksheets("データ").Cells(3, p) '"データ"シートのB列の数
Set myRange = srcRange.Find(What:=c.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not myRange Is Nothing Then
myAddress = myRange.Address
i = 1
Do
c.Offset(i).Value = myRange.Offset(, 1).Value
Set myRange = srcRange.FindNext(After:=myRange)
i = i + 1
Loop Until myRange.Address = myAddress
End If
Next
Next p
Application.ScreenUpdating = True
End Sub

回答No.2

watabe007

>ただRange("C3:E3") と直接指定しているのでデータの分類項目が増えたとき変更が・・

>For Each c In Worksheets("データ").Range("C3:E3")
　　↓　　　↓　　　↓
　With Worksheets("データ")
　　　Set bunRange = .Range("C3", .Cells(3, Columns.Count).End(xlToLeft))
　End With
　For Each c In bunRange

お礼

どうもありがとうございます。
助かります。