セルの値から任意の文字のみを抽出する

質問

こんにちは。
VBA勉強中です。
どうしても詰まってしまったので力を貸してください。・゜・(ノД｀)・゜・。

Sheet１にはA列～J列にデータが入っています（行数は3行目～□行目・・・都度変わります）
Sheet2には抽出したい文字の一覧（仮に禁止ワードとします）がB列5行目～○行目まで入ってます。

質問としてはSheet１のB列、D列、F列のそれぞれの値より禁止ワードを抽出する。
1つのセルに禁止ワードが0～最大5つ入っている時にK列から→方向に禁止ワードを並べて行くといった
感じです。
わかりにくくてすみませんが宜しくお願い致します。

以下自分で考えてみたコードです。。
これだと始めのB列のみ抽出に成功しましたがその他の列からは抽出できず・・・。゜(PД｀q。)゜。
列Bで使用したコードをD列、F列にも使えると下に数値のみ変えて羅列しただけだからでしょうか；ｗ；
本当に初心者ですみません。。

以下コードです。

Sub 禁止ワード抽出()

Dim SR As Integer , LR As Integer, SR2 As Integer , LR2 As Integer , LR3 As Integer , LR4 As Integer
Dim i As Long , j As Long , k As Long , m As Long
Dim KINSHI As Variant

SR = 3
SR2 =5
LR = Sheets("Sheet1").Range("B" Rows.Count).End(xlUp).Row
LR2 = Sheets("Sheet1").Range("D" Rows.Count).End(xlUp).Row
LR3 = Sheets("Sheet1").Range("F" Rows.Count).End(xlUp).Row
LR4 = Sheets("Sheet2").Range("B" Rows.Count).End(xlUp).Row

For j = SR2 To LR4
KINSHI = Sheets("Sheet2").Cells(j , 2).Value

For i = SR To LR
If Sheets(Sheet1).Cells(i , 2).Value Like ("*" & KINSHI & "*") Then
If Cells(i , 10) = "" Then
Cells(i , 10) = KINSHI

Else
　 If Cells(i , 10 + 1) = "" Then
Cells(i , 10 + 1) = KINSHI

Else
　 If Cells(i , 10 + 2) = "" Then
Cells(i , 10 + 2) = KINSHI

Else
　 If Cells(i , 10 + 3) = "" Then
Cells(i , 10 + 3) = KINSHI

Else
　 If Cells(i , 10 + 4) = "" Then
Cells(i , 10 + 4) = KINSHI

End If
End If
End If
End If
End If
End If
Next i , j

以下上記コードをD列、F列バージョンで並べています・・・・

End Sub

恐らくOffsetプロパティを使う方がいいと思いましたが中々うまくいかず
自分なりに色々考えてみてこんな残念な結果になってしまいましたが
皆様のお力添えどうぞ宜しくお願い致します。

回答No.1

keithin · ベストアンサー

とりあえず簡易版：
sub macro1()
　dim h as range
　dim c as range
　dim c0 as string

　for each h in worksheets("Sheet2").range("B5:B" & worksheets("Sheet2").range("B65536").end(xlup).row)
　　with worksheets("Sheet1").range("B:B,D:D,F:F")
　　set c = .find(what:=h.value, lookin:=xlvalues, lookat:=xlpart)
　　if not c is nothing then
　　　c0 = c.address
　　　do
　　　　worksheets("Sheet1").cells(c.row, application.max(11, worksheets("Sheet1").cells(c.row, "IV").end(xltoleft).column + 1)) = h.value
　　　　set c = .findnext(c)
　　　loop until c.address = c0
　　end if
　　end with
　next
end sub

＃やってみて「こーじゃない」のは説明が足りてない部分なので，適宜工夫して下さい。

お礼

出来ました！
本当にありがとうございました。
精進致します(>_<)