Excel VBA 別シートのデータ取得後 検索

質問

ブックAを開いています。
シートは「2013年1月」と「作業項目」の二つあり、
2013年1月にはカレンダーを作成しております。

また作業項目にはA1から順にA2,A3....と
文字列が記載されています。

この文字列をA1から順番にカレンダーの方で検索していき、該当すれば赤色に変更したいです。
(※セル内全ての文字列ではなく、該当文字列のみ赤色に変更)

宜しくお願い致します。

回答No.2

n-jun · ベストアンサー

＃１です。

セルにどのようなデータがあるのかがわかりませんが、
例えば作業項目のセルに　21:00　を入れていると
実際には　21:00:00　となってしまい

＞資料作成(21:00～)
が検索で見つからない可能性があります。

よって

＞Set rf = ws2.Cells.Find(What:=r.Value, LookIn:=xlValues, LookAt:=xlPart)

＞myReg.Pattern = r.Value

上記２つを

Set rf = ws2.Cells.Find(What:=r.Text, LookIn:=xlValues, LookAt:=xlPart)

myReg.Pattern = r.Text

と差し替えてみて下さい。

お礼

無事作成したい資料が出来ました。

丁寧な回答をして頂き、有難うございます。

回答No.1

n-jun

シート名は実際の名前に修正してください。

Sub try()
Dim myReg As Object
Dim match As Variant
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim r As Range
Dim rf As Range
Dim sr As String

Set myReg = CreateObject("VBScript.Regexp")
myReg.Global = True

Set ws1 = Worksheets("Sheet1") ' 作業項目シート
Set ws2 = Worksheets("Sheet2") ' カレンダー？

With ws1

For Each r In .Range(.[A1], .Cells(Rows.Count, 1).End(xlUp))

Set rf = ws2.Cells.Find(What:=r.Value, LookIn:=xlValues, LookAt:=xlPart)

If Not rf Is Nothing Then

myReg.Pattern = r.Value
sr = rf.Address

Do

For Each match In myReg.Execute(rf.Value)
rf.Characters(Start:=match.Firstindex + 1, Length:=match.Length).Font.ColorIndex = 3 ' フォントカラーを赤
Next

Set rf = ws2.Cells.FindNext(rf)

Loop Until rf.Address = sr

End If

Next

End With

Set myReg = Nothing
Set rf = Nothing

End Sub

こんな感じでしょうか？

お礼

ご回答有難うございます。
先ほど試した結果、文字列の色変更が無事出来ました。

1点お伺いしたいのですが、記号(主に括弧やコロン)を含んだ文字列で同様の作業は出来るでしょうか？
(例)
資料作成(21:00～)

お答えしていただいたのにも関わらず、不躾な質問となり申し訳ございませんが
宜しければご教示願います。