エクセル（VBA） 検索条件に文字色を含める

エクセルについて質問です。
エクセルのバージョンは2007を使用しています。

基本的にはCOUNTIFS関数やSUMPRODUCT関数の考え方で複数条件を満たすセルの個数を数えたいのですが
その検索条件のうちのいくつか（正確には3つの列）において、特定文字が何色かを見たいのです。

具体的には下の添付ファイルの備考A～備考Cの列のように、その3つの列のセルの中にそれぞれ黒文字（自動）、黒文字（自動）太字、赤文字、青文字が混在しており、その文字列の羅列の規則性としては

１．セル内の文字列は必ず、上で挙げた4種のフォントスタイルのうちのいずれかの # で始まる。

２．#A #B #C (#D) のように、セル内の文字列は一連の小文字列が半角スペースで区切られているとともにその一連の小文字列の最初の文字は必ず # もしくは (# であり、またその一連の小文字列は同一色同一の太さである。

３．(#A) のような、() で囲んだ一連の小文字列は黒文字（自動）スタイルだけであり、また１．でも述べたようにセル中の文字列の最初に来ることはない。

となっております。

そこでそれぞれの列について、黒文字（自動）もしくは黒文字（自動）太字もしくは青文字の # で始まるセルを検索し（つまり赤文字の # で始まるセルと何も記述のない空白のセルを除く）、

その3列を and もしくは or 条件で組み合わせ、更に1、2個条件を加えて該当する行の数をCOUNTIFS関数やSUMPRODUCT関数のように数え、返したいと思っております。

恐らくVBAを利用することとなると思います。まだまだVBAを自分で一から構築することは難しいのですが、ある程度VBAを読み解き理解していくことは可能なレベルですので、どうか大まかな構文の枠組みだけでもご教授いただけると幸いです。

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

No.1 ベストアンサー 回答者： tom04 回答日時： 2013/08/28 11:17

こんにちは！

単純に、セル内に「赤」のフォントがない行のG列に「1」を表示するようにしてみました。

画面左下の操作したいSheet見出し上で右クリック　→　コードの表示　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub Sample1() 'この行から
Dim i As Long, j As Long, k As Long, c As Range, myFlg As Boolean
Range("G:G").ClearContents
For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
If WorksheetFunction.CountA(Range(Cells(i, "D"), Cells(i, "F"))) > 0 Then
For j = 4 To 6
If Cells(i, j) <> "" Then
For k = 1 To Len(Cells(i, j))
If Cells(i, j).Characters(Start:=k, Length:=1).Font.ColorIndex = 3 Then
myFlg = True
Exit For
End If
Next k
End If
Next j
If myFlg = False Then
Cells(i, "G") = 1
End If
myFlg = False
End If
Next i
End Sub 'この行まで

※　フォント色は手動でつけているという前提です。（条件付き書式ではない）
これでG列にその行のセルで「赤」のフォントが１個もない場合は「1」が表示されますので
後はSUM関数等で対応してみてください。m(_ _)m

この回答へのお礼

tom04さま

早速ご回答くださりありがとうございます。

まずは別件になりますが、以前ここで質問させていただいた帳票出力の件で教えていただいたマクロは今でも多少手を加えたりしつつ大事に利用させていただいており、おかげさまで業務もかなり楽になっております。たいへん便利なものを本当にありがとうございました。

さて今回の件では正確に申しますと「セル内に赤のフォントがない」かどうかではなく「セル内の先頭の文字が（常に#なのですが）赤のフォントでない、もしくはセル内が空白である」かそうでないかで分類したいため多少コードは違ってくるだろうと思いますが
今後自分でこのマクロを使いこなしメンテナンスすることができるようにするためにも、何とかここからのアレンジは自分自身で頑張ってみようと思います。

今後アレンジしていく中でどうしてもわからない、うまくいかないところが出てきましたら再度ここで別の項を設けて質問させていただきたいと思っておりますのでもし見かけられましたら再度ご教授いただけると幸いです。今回もほんとうにありがとうございました。

お礼日時：2013/08/29 02:06

No.5 回答者： kmetu 回答日時： 2013/08/28 17:59

補足

For j = 1 To 3
Range("G" & j) = MyText(j - 1)
Next j

より

その上の最後にところで

Next

Range("G" & i + 1) = MyText(i)

Next i

と入れ込んだほうが単純ぽいですね。

この回答へのお礼

kmetu　さま

早速の御回答ありがとうございます。私のやろうとしていることが煩雑でまた私の伝達能力不足でいろいろとご迷惑をおかけいたしました。実はこのD列～F列の中の該当条件を満たす行数を直接数えるのではなく、あくまでその3列は更にあと1、2個ある条件と組み合わせていく必要があるので多少ここからアレンジを加えていく必要があるのですが、いただいたコードを参考にさせていただきこの後はなんとか自分で頑張って思い通りのものをデザインしていきたいと思っています。

今後デザインしていく中でどうしてもうまくいかない、またわからないところが出てきましたら再度ここで別に質問させていただきたいと思っております。ですので、もし見かけられましたら再度ご教授いただけると幸いです。この度はほんとうにありがとうございました。

お礼日時：2013/08/29 02:22

No.4 回答者： kmetu 回答日時： 2013/08/28 17:39

すみません行の数だったんですね　文字列の個数を計算してました

行の数でしたら

Sub Sample()

Dim MyText(3) As Integer, MyStart As Integer, MyLength As Integer, MyCount As Integer
Dim c As Range

For i = 0 To 2
For Each c In Range(Cells(2, 4 + i), Cells(9, 4 + i))

MyStart = InStr(c.Value, "#")
MyLength = Len(c.Value) - InStr(MyStart, c.Value, " ")
MyCount = 1
MyFlg = True
If c.Value <> "" Then
Do
Select Case c.Characters(MyStart, MyLength).Font.Color
Case vbRed
MyFlg = False
Case Else
End Select

If MyLength <> 0 Then
MyStart = InStr(MyLength, c.Value, "#")
End If

If MyStart <> 0 Then
MyLength = InStr(MyStart - 1, c.Value, " ")
End If

MyCount = MyCount + MyLength

Loop Until Len(c.Value) < MyCount
End If
If MyFlg = True And c.Value <> "" Then
MyText(i) = MyText(i) + 1
End If
Next
Next i

For j = 1 To 3
Range("G" & j) = MyText(j - 1)
Next j

End Sub

G1から下にD列E列F列の順で行数を書き出します。

No.3 回答者： kmetu 回答日時： 2013/08/28 16:18

補足です

こちらより

Select Case c.Characters(MyStart, MyLength).Font.ColorIndex
Case Is <> 3

こちらの方が分かりやすいかもしれません

Select Case c.Characters(MyStart, MyLength).Font.Color
Case Is <> vbRed

それとデータのないセルを考えてなかったので

Do
の前に
If c.Value <> "" Then
を
Loop Until Len(c.Value) < MyCount
の後に
End If
を追加してください。

No.2 回答者： kmetu 回答日時： 2013/08/28 15:55

赤を除くということで　G1に赤を除いたその個数を表示します。

Sub Sample()

Dim MyText As Integer, MyStart As Integer, MyLength As Integer, MyCount As Integer
Dim c As Range

For Each c In Range("D2:F9")

MyStart = InStr(c.Value, "#")
MyLength = Len(c.Value) - InStr(MyStart, c.Value, " ")
MyCount = 1

Do
Select Case c.Characters(MyStart, MyLength).Font.ColorIndex
Case Is <> 3
MyText = MyText + 1
Case Else
End Select

If MyLength <> 0 Then
MyStart = InStr(MyLength, c.Value, "#")
End If

If MyStart <> 0 Then
MyLength = InStr(MyStart - 1, c.Value, " ")
End If

MyCount = MyCount + MyLength

Loop Until Len(c.Value) < MyCount

Next

Range("G1") = MyText

End Sub