Excel 取り込んだシート中の該当データを抽出、色づけについて

以前、エクセルのマクロで以下の質問をさせて頂きましたものです。
https://oshiete.goo.ne.jp/qa/8898635.html
その節は大変お世話になりました。

今回もまたマクロのお話で大変恐縮なのですが、
以前頂戴したマクロを少し改造することになりました。

以前のマクロは上記URLに記載の通り、
1．ボタンを押すとA1セルに記述されたパスのブックを開く
2．開いたブックのシートを全てコピーしてくる
3．その際に"東京都"という文字列があれば、そのセルを赤く塗る
という内容のマクロです。

今回、このマクロを改変するのですが、改変点が
・検索文字列「東京都」の部分を、C列に記述された内容にする
・検出された場合、セルではなく文字列を塗る
としたく思っております。

InStrにて対象をマクロ中で決めうちにするのではなく、
今回これを柔軟にしたいと思っているのですが(C列に記述)、
InStrのセルを指定する方法がうまく動かず、困っております。

身の丈に合わないエクセルのマクロを組みたいというのが我が儘で自分の勉強不足なのですが、
ご存じの方、ご教示頂ければ幸いです。

よろしくお願いいたします。

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

• ご回答ありがとうございます。お心遣い、大変感謝しております。
  また、ご連絡が大変遅くなりましたこと、お詫び申し上げます。
  
  一点、確認させて頂きたいことがあります。
  今回頂戴いたしましたコードだと、「東京都」を含むセルの文字列全てが赤になりますが、
  これを「東京都」だけを赤にすることは可能でしょうか。
  
  実を申し上げますと、「〜〜区」が検出出来ると汎用性が高まります。
  つまり、C列に「東京都」を入力するだけで、「東京都〜〜区」の文字のみが赤くなる、ということです。
  実際には神奈川県のデータもあるため、C列には以下のように入力する予定です。
  東京都
  神奈川県
  これで、「東京都〜〜区」「東京都〜〜市」「神奈川県〜〜区」「神奈川県〜〜市」が赤になる、ということです。
  
  本来、専門の業者へお願いするようなプログラムをここでお伺いしていることは分かっております。
  お礼をして差し上げたい次第です。

  No.1の回答に寄せられた補足コメントです。 補足日時：2015/02/02 16:25

No.2 ベストアンサー 回答者： tom04 回答日時： 2015/02/02 19:34

No.1です。

都道府県・市区町村　を区切る！という作業はかなり厄介です。
Excel的には都道府県と市区町村の区別はつきませんので、こちらで条件付けする必要があります。

しかし　三重県四日市市・千葉県市川市・広島県廿日市市・・・等々のように
市町村名の中に「市」が含まれているものがあったり、あるかどうかは判りませんが
「区」という文字が市町村名の中にあればどうしようもなくなります。

ただ、これでは何もお役に立てないので
少しやってみました。

Sub Sample4()
Dim wS As Worksheet, wB As Workbook, wS1 As Worksheet
Dim i As Long, k As Long, c As Range
Dim cnt As Long, str As String

Set wS1 = Worksheets("Sheet1")
Application.ScreenUpdating = False

Workbooks.Open Worksheets("Sheet1").Range("A1")
Set wB = ActiveWorkbook
ThisWorkbook.Activate
For k = 1 To wB.Worksheets.Count
Worksheets.Add after:=ActiveWorkbook.Worksheets(Worksheets.Count)
Set wS = ActiveSheet
wS.Name = wB.Worksheets(k).Name & "(" & k & ")" '←Sheet名に重複がない場合はこの行は不要！
wB.Worksheets(k).Cells.Copy wS.Range("A1")
For i = 2 To wS1.Cells(Rows.Count, "C").End(xlUp).Row
If wS1.Cells(i, "C") <> "" Then
For Each c In wS.UsedRange
If InStr(c, wS1.Cells(i, "C")) > 0 Then
If InStr(c, "区") > 0 Or InStr(c, "市") > 0 Then
For cnt = Len(wS1.Cells(i, "C")) + 2 To Len(c)
str = Mid(c, cnt, 1)
If str = "区" Or str = "市" Then Exit For
Next cnt
c.Characters(Start:=1, Length:=cnt).Font.ColorIndex = 3
End If
End If
Next c
End If
Next i
Next k
wB.Close
Application.ScreenUpdating = True
End Sub

※　とりあえず「市川市」のように「市」が続いていない場合は「市川市」まで赤になると思います。
ただし、「四日市市」のように「市」が連続する場合は「四日市」までしか色が付きません。

※　追加したSheetにデータがあればすべてのセルを検索していますので
本来であれば○列が「住所」の列！と判ればピンポイントでその列だけのループが可能になり
若干の時間短縮ができるかもしれません。

とりあえずはこの程度で・・・m(_ _)m

この回答へのお礼

ご回答が大変遅くなりましたこと、お詫び申し上げます。

幾たびもご丁寧に補足頂き、またご丁寧に色々なパターンまでご考慮下さったこと、
深く感謝申し上げます。ありがとうございました。

なかなか難しいコードですが、工夫次第でなんとか適用出来そうです。
頑張ってみます。

本当にお世話になりました。ありがとうございました。

お礼日時：2015/02/09 18:35

No.1 回答者： tom04 回答日時： 2015/01/29 21:09

こんばんは！

前回回答した者です。

＞・検索文字列「東京都」の部分を、C列に記述された内容にする
とは、どのSheetのC列の何行目からのデータなのかがはっきり判りませんが、
ThisWorkbook（コードを記載しているBook）のSheet1のC列2行目以降に検索文字列があるという前提のコードです。
前回のコードに少し手を加えてみました。
「★」の行が追加・修正した部分です。

Sub Sample3()
Dim wS As Worksheet, wB As Workbook, wS1 As Worksheet '★
Dim i As Long, k As Long, c As Range, myRng As Range

Set wS1 = Worksheets("Sheet1") '←ThisWorkbookのSheet1を変数「wS1」に格納　★
Application.ScreenUpdating = False
'▼　GetOpenFilename　でA1セルにコピー元のパスとファイル名が取得できているという前提
Workbooks.Open Worksheets("Sheet1").Range("A1")

Set wB = ActiveWorkbook
ThisWorkbook.Activate
For k = 1 To wB.Worksheets.Count
Worksheets.Add after:=ActiveWorkbook.Worksheets(Worksheets.Count)
Set wS = ActiveSheet
wS.Name = wB.Worksheets(k).Name & "(" & k & ")" '←Sheet名に重複がない場合はこの行は不要！
wB.Worksheets(k).Cells.Copy wS.Range("A1")
For i = 2 To wS1.Cells(Rows.Count, "C").End(xlUp).Row '←ThisWorkbook、Sheet1のC列2行目～最終行まで　★
If wS1.Cells(i, "C") <> "" Then
Set myRng = wS.Cells.Find(what:=wS1.Cells(i, "C"), LookIn:=xlValues, lookat:=xlPart) '★
If Not myRng Is Nothing Then
For Each c In wS.UsedRange
If InStr(c, wS1.Cells(i, "C")) > 0 Then '★
Set myRng = Union(myRng, c)
End If
Next c
myRng.Font.ColorIndex = 3 '★
End If
End If
Next i '★
Next k
wB.Close
Application.ScreenUpdating = True
End Sub

※　前回同様「含む」という前提のコードですので、
Sheet1のC列文字列が含まれているセルのフォントが「赤」になります。

※　完全一致にしたい場合は
＞Set myRng = wS.Cells.Find(what:=wS1.Cells(i, "C"), LookIn:=xlValues, lookat:=xlPart)
を
＞Set myRng = wS.Cells.Find(what:=wS1.Cells(i, "C"), LookIn:=xlValues, lookat:=xlWhole)

＞If InStr(c, wS1.Cells(i, "C")) > 0 Then
を
＞If c=wS1.Cells(i, "C") Then
の2行を変更してください。m(_ _)m