Excel VBAでループ？続けて処理をする方法を教えてください。

VBAの初心者です。色々調べたのですがわからなかったので、こちらで質問させていただきます。

A列にある文字列に対して、B列にある単語を抽出し、赤字で表示させるというマクロを組みたいです。
B列1行目の単語を抽出させるところまでは何とかなったのですが、B列2行目へ処理を移行？させるやり方がわかりません。

どなたかご教授いただけますと幸いです。

----------------------------------------------
Sub test2()
Dim rng As Range, cl As Range, i As Long
With ActiveSheet
Set rng = .Range("a1:a100")
txt = Range("b1").Value
For Each cl In rng
s = 1
While s <= Len(cl)
p = InStr(s, cl, txt, 1)
If p > 0 Then
cl.Characters(p, Len(txt)) _
.Font.Color = vbRed
s = s + p
Else
GoTo p1
End If
Wend
p1:
Next
End With
End Sub
----------------------------------------------

質問者からの補足コメント

• hiro40199210さま
  
  ご回答、検証までしていただきありがとうございます！
  ただ私の質問の仕方が悪かったため、意図が伝わっておりませんでした。
  すみません。
  
  やりたいことは、
  
  ・A列に文章がある
  　例）A1：私は日本人です。日本が好きです。
  　　　A2：ご飯がおいしいからです。
  ・B列に単語がある
  　例）B1：日本
  　　　B2：ご飯
  
  ここでA列の文章中にある「日本」と「ご飯」を赤字に変換させたいのです。
  伝わりましたでしょうか？
  お手数おかけしますが、再度ご教授いただけないでしょうか。

    補足日時：2016/08/01 19:40

No.1 回答者： hiro40199210 回答日時： 2016/08/01 19:29

Set rng = .Range("a1:a100")

これを下記のものに変更すればokです。

Set rng = .Range("a1:j100")

JMEV
TQBC
NVFO
MOLK
WRVL
FGNM

ランダムなアルファベット四文字の文字列をa1:j10000(10万セル）に入れて、検索値[AB]をにして検証してみました。
0.7秒程度で処理が終了しました。

No.2 回答者： hiro40199210 回答日時： 2016/08/01 19:31

×これを下記のものに変更すればokです。

◎これを下記のように変更すればokです。
.Range("a1:j100")は例です。

この回答へのお礼

hiro40199210さま

ご回答、検証までしていただきありがとうございます！
ただ私の質問の仕方が悪かったため、意図が伝わっておりませんでした。
すみません。

やりたいことは、

・A列に文章がある
　例）A1：私は日本人です。日本が好きです。
　　　A2：ご飯がおいしいからです。
・B列に単語がある
　例）B1：日本
　　　B2：ご飯

ここでA列の文章中にある「日本」と「ご飯」を赤字に変換させたいのです。
伝わりましたでしょうか？
お手数おかけしますが、再度ご教授いただけないでしょうか。

お礼日時：2016/08/01 19:38

No.3 回答者： tatsu99 回答日時： 2016/08/01 20:58

以下のようにしてください。

---------------------------------------
Sub Macro1()
Dim i As Long
Dim rowmax As Long
Dim txt As Variant
Dim s As Variant
Dim p As Variant
With ActiveSheet
rowmax = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To rowmax
txt = Cells(i, 2)
If txt <> "" Then
s = 1
Do While True
p = InStr(s, Cells(i, 1), txt)
If p > 0 Then
Cells(i, 1).Characters(p, Len(txt)).Font.Color = vbRed
s = s + Len(txt)
Else
Exit Do
End If
Loop
End If
Next
End With
End Sub
------------------------------------
私は日本人です。日本が好きです。　　・・・日本　が2か所赤色に変換
ご飯がおいしいからです。　　　　　　・・・ご飯　が1か所赤色に変換
を確認済みです。

No.4 回答者： WindFaller 回答日時： 2016/08/01 21:39

ご質問のマクロそのものは、時々出てくるものだと思います。

私自身、以前から作ってみたいと考えていました。
今回、私が作ったものは、ちょっと違ったテーストがあります。
それは、「正規表現」が使えるということです。ちょっと変えると、かなり複雑な色付けも可能になります。もし、興味がありましたら、ご紹介します。


'//
Sub FindWords()
Dim c As Range
Dim x As Variant, f As Long, l As Long
Dim i As Long
Dim Re As Object
Dim FirstAddress As String
Dim Matches, m As Variant

Set Re = CreateObject("VBScript.RegExp")
Re.Global = True

With Worksheets("Sheet2").Columns(1)
x = .Range(.Cells(1, 2), .Cells(Rows.Count, 2).End(xlUp)).Value
x = Application.Transpose(x)
For i = LBound(x) To UBound(x)
Set c = .Find(What:=Trim(x(i)), LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns)
　　 If Not c Is Nothing Then
　　　　FirstAddress = c.Address
　　　　Do
　　　　Set c = .FindNext(c)
　　　　Re.Pattern = x(i)
　　　　Set Matches = Re.Execute(c.Value)
　　　　For Each m In Matches
　　　　　f = m.firstindex + 1: l = m.Length
　　　　　c.Characters(f, l).Font.Color = vbRed
　　　　Next m
　　　　
　　　　If c.Address = FirstAddress Then Exit Do
　　　　Loop Until c Is Nothing
　　 End If
Next i
End With
　　Set Re = Nothing
End Sub

以下は、コマンドをちょっと間違えてしまいましたが、日本[一-龠]* とすれば、正規表現で日本のみにも色が付きます。

No.5 回答者： tom04 回答日時： 2016/08/02 10:25

こんにちは！

すでに回答は出ていますので、参考程度で・・・

Sub Sample1()
Dim i As Long, myFound As Range, myFirst As Range
For i = 1 To Cells(Rows.Count, "B").End(xlUp).Row
Set myFound = Range("A:A").Find(What:=Cells(i, "B"), LookIn:=xlValues, LookAt:=xlPart)
If Not myFound Is Nothing Then
Set myFirst = myFound
myFound.Characters(Start:=InStr(myFound, Cells(i, "B")), Length:=Len(Cells(i, "B"))).Font.ColorIndex = 3
Do
Set myFound = Range("A:A").FindNext(after:=myFound)
If myFound.Address = myFirst.Address Then Exit Do
myFound.Characters(Start:=InStr(myFound, Cells(i, "B")), Length:=Len(Cells(i, "B"))).Font.ColorIndex = 3
Loop
End If
Next i
End Sub

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

No.6 回答者： tom04 回答日時： 2016/08/02 10:51

No.5です。

前回のコードは消去して↓のコードに変更してください。
1セル内に該当文字列が複数ある場合に対処できていませんでした。

Sub Sample3()
Dim i As Long, k As Long, myStr As String
Dim myFound As Range, myFirst As Range
For i = 1 To Cells(Rows.Count, "B").End(xlUp).Row
myStr = Cells(i, "B")
Set myFound = Range("A:A").Find(What:=myStr, LookIn:=xlValues, LookAt:=xlPart)
If Not myFound Is Nothing Then
Set myFirst = myFound
GoTo 処理
Do
Set myFound = Range("A:A").FindNext(after:=myFound)
If myFound.Address = myFirst.Address Then Exit Do
GoTo 処理
処理:
For k = 1 To Len(myFound)
If Mid(myFound, k, Len(myStr)) = myStr Then
myFound.Characters(Start:=k, Length:=Len(myStr)).Font.ColorIndex = 3
End If
Next k
Loop
End If
Next i
End Sub

どうも失礼しました。m(_ _)m