エクセルでの文字色を数える関数に関して。。。

質問

エクセルのセル内の文字色に関してのマクロを下記の通り書きました。

Function SpecialCell(targetRange As Range, _
intColor As Integer) As Integer
'赤は3，緑は4，青は5，黄は6
Dim myCell As Range

For Each myCell In targetRange
If myCell.Font.ColorIndex = intColor _
Or myCell.Interior.ColorIndex = intColor Then
SpecialCell = SpecialCell + 1
End If
Next
End Function

その後答えを求めるセルに
=SpecialCell(D5:D125,3)

これはちゃんと表示できます。

しかし、
=SpecialCell(D10,D8,D29,D49,D51,D57,3)

このようにセルの個別ごとに求めようとすると
#VALUE!

が出ますので引数が間違っているのだとは思うのですが、
この場合はどうすればよろしいでしょうか？

また、セル内に複数の色つき文字がある場合、
例えば同一セル内に
(1)(2)(3)
とあって、
(1)が赤
(2)が青
(3)がピンク

とした場合、
=SpecialCell(D5:D125,3)
これでは０と出てきてしまいます。。。
この場合はどういう風に数式をいれればよいのでしょうか？

以上2点ほどご教授いただけると助かります。
よろしくお願いいたします。。。

回答No.11

Cor_moriyan · ベストアンサー

kmetu さんの「セル範囲を（）で囲む」を私のソースに適用させてもらって(^^;
ん？ (1) は【丸囲み数字１】ですか？では

Function SpecialCell(TargetRange As Range, intColor As Integer) As Integer
　　'赤は3，緑は4，青は5，黄は6
　　Dim myCell　　　As Range
　　Dim intIDX　　　As Integer
　　Dim strVALUE　　As String

　　For Each myCell In TargetRange
　　　　If myCell.Font.ColorIndex = intColor Then
　　　　　　SpecialCell = SpecialCell + 1
　　　　　　GoTo SkipFor
　　　　End If
　　　　If myCell.Interior.ColorIndex = intColor Then
　　　　　　SpecialCell = SpecialCell + 1
　　　　　　GoTo SkipFor
　　　　End If
　　　　If myCell.Value <> "" Then
　　　　　　For intIDX = 1 To Len(myCell.Value)
　　　　　　　　If myCell.Characters(intIDX, 1).Font.ColorIndex = intColor Then
　　　　　　　　　　SpecialCell = SpecialCell + 1
　　　　　　　　End If
　　　　　　Next
　　　　End If

SkipFor:
　　Next

End Function

これで、=SpecialCell((D10,D8,D29,D49,D51,D57),3)　のように書けばＯＫかと。

お礼

たびたびありがとうございます。

このコードを試したところ、無事D欄・E欄ともに計算してくれました。

そして恐縮ながらもう一つ教えていただけると助かります。。。

Dの縦欄は、セル内背景色を分けているのと、文字色は1色です。
（なので、背景色ごとのセル分けで集計するための問１でした）

このセル内の背景色を4色で分けているのですが、中の文字色は関係なく、背景色の数字を数えるのはできますでしょうか？

%を出す為に、現在背景色を手計算で問１で教えていただいた数字で割っております。。。
この背景色も計算できると非常に助かります。。。
（現在のD欄とE欄の計算式が壊れないよう）

http://miyahorinn.fc2web.com/tips/s_02_02_04_02.html
とりあえず、これを元に作成してみますけど、問題があればご教授下さいませ。
よろしくお願いたします。。。

そしてありがとうございました。。。
助かりました。。。

補足

ごめんなさい。下記のURLでいけました。

今までの経緯を思うと、壊れるの前提で書いてしまいましたｗ

ありがとうございました。。。

回答No.12

kmetu

> 現在入れているマクロでD欄は正常に統計が取れます。
> E欄の統計を取るマクロを入れるとD欄が壊れる。

入れるとはどういう意味でしょうか？

同じ名前(Function SpecialCell)で

> なので、標準モジュール1を最初の奴
> 標準モジュール２を教えていただいた奴

としたのでしょうか。でしたらそれは無茶でしょうし"名前が適切ではありません。"
とエラーが出るのは当然です。

とりあえず名前を変えて試すか、私の示したコードだけで試してください。

丸付きの文字3文字でしたら

/3は不要で
=SpecialCell(E6:E126,3)
=SpecialCell(E6:E126,5)

でいけます。

お礼

>エラーが出るのは当然です。

すいません、基本素人なもので、とりあえず試してみただけですｗ

そして、やはりANo.7のコードに変えて、それまで計算していたD欄の統計部分の計算式を再計算するとコンパイルエラーがでます。。。

=SpecialCell(E6:E126,3)
でE欄のところに埋め込んでもやはり計算してくれませんでした。。。

ANo.11さんのコードを入れてみたところ1回答えが全ておかしくなりましたが、エラーではなかったため、再計算すると元に戻り、D欄＆E欄も無事に計算できました。
こちらのコードでもう少々ごにょごにょしてみたいと思います。

長い間ご教授いただきありがとうございました。。。
また、よろしくお願いいたします。。。

回答No.10

Cor_moriyan

補足を読みました。
(1)(2)(3)で・・・という事なら、「)」「(」を無視して 123 だけ判定すれば良いですね(^^)
なので

Function SpecialCell(RangeString As String, intColor As Integer) As Integer
　　'赤は3，緑は4，青は5，黄は6
　　Dim TargetRange As Range
　　Dim myCell　　　As Range
　　Dim intIDX　　　As Integer
　　Dim strVALUE　　As String

　　Set TargetRange = ActiveSheet.Range(RangeString)

　　For Each myCell In TargetRange
　　　　If myCell.Font.ColorIndex = intColor Then
　　　　　　SpecialCell = SpecialCell + 1
　　　　　　GoTo SkipFor
　　　　End If
　　　　If myCell.Interior.ColorIndex = intColor Then
　　　　　　SpecialCell = SpecialCell + 1
　　　　　　GoTo SkipFor
　　　　End If
　　　　If myCell.Value <> "" Then
　　　　　　'"("と")"を取り除く
　　　　　　strVALUDE = Replace(Replace(myCell.Value,"(",""),")","")
　　　　　　For intIDX = 1 To Len(strVALUE)
　　　　　　　　If myCell.Characters(intIDX, 1).Font.ColorIndex = intColor Then
　　　　　　　　　　SpecialCell = SpecialCell + 1
　　　　　　　　End If
　　　　　　Next
　　　　End If

SkipFor:
　　Next

End Function

関数の書き方は　=SpecialCell("A1,D1,C1",3)　などと、セル範囲を【文字列】で渡す事に変わりはありません。

回答No.9

Cor_moriyan

=SpecialCell("D10,D8,D29,D49,D51,D57",3)
のように、検査したいセルのアドレスをダブルクォーテーション「"」で囲んで下さい。

↑
です。アドレスの指定している部分を「"」で囲んで「文字列」にしてください。
通常のセル範囲指定とは異なります。

回答No.8

kmetu

> 具体例が3文字なので1セット3文字と考えてます。

(1)を1セット3文字という意味です。

補足

あ、ごめんなさい。

括弧で出てきちゃうのですが、実際には丸がこみの数字で
(1)(2)(3)←これでワンセット3文字です。

ややこしくてすいません。

回答No.7

kmetu

> E欄の統計を取る際に、例えば同一セル内で
>
> (1)(2)(3)（左から、赤・黒・青）
> (1)(2)(3)（左から、黒・黒・赤）
> (1)(2)(3)（左から、青・赤・青）
>
> これの回答を
> 赤　3個
> 青　3個
> ピンク　0個
>
> というような集計をしたくて、ご相談しました。。。

Function SpecialCell(targetRange As Range, _
intColor As Integer) As Integer
'赤は3，緑は4，青は5，黄は6
Dim myCell As Range
Dim myFlg As Boolean

Function SpecialCell(targetRange As Range, _
intColor As Integer) As Integer
'赤は3，緑は4，青は5，黄は6
Dim myCell As Range

For Each myCell In targetRange
For i = 1 To Len(myCell.Value)
If myCell.Characters(Start:=i, Length:=1).Font.ColorIndex = intColor _
Or myCell.Interior.ColorIndex = intColor Then
SpecialCell = SpecialCell + 1
End If
Next
Next
End Function

前回のコードに元にあったOr myCell.Interior.ColorIndex = intColorを足してます。
(足さなくてもE列に関しては同じですが)

で

=SpecialCell(E6:E126,3)/3
=SpecialCell(E6:E126,5)/3

これでこちらでは希望の数値が出ました。具体例が3文字なので1セット3文字と考えてます。

> ちなみに標準モジュールに下記コードを追加して両方走らせると、

両方走らせるというのがちょっと意味がわかりません。

補足

早々の解答ありがとうございます。

早速いれてみたところ、、、
コンパイルエラー　名前が適切ではありません。
っと出ましてD欄の統計部分もダメになりました。
（#NAME）
いけそうな気がしたのですが、、、

>両方走らせるというがちょっと意味がわかりません。

現在入れているマクロでD欄は正常に統計が取れます。
E欄の統計を取るマクロを入れるとD欄が壊れる。

なので、標準モジュール1を最初の奴
標準モジュール２を教えていただいた奴

とやればうまくいけるかな？
っと思ったので試してみたらダメでしたｗ
という意味です。

回答No.6

tom04

こんばんは！
せっかくコードをお考えのようなので、余計なお世話になるかもしれませんが・・・

セルを範囲指定した後に実行するマクロを考えてみました。
（Sheet2を作業用のSheetとして使用していますので、Sheet2は使用していないという前提です）

Sheet1のマクロにしていますので、画面左下にあるSheet1のSheet見出し上で右クリック　→　コードの表示　→　↓のコードをコピー＆ペーストし、範囲指定した後にマクロを実行してみてください。

Sub test()
Dim c As Range
Dim i As Long
Dim str As String
Dim ws As Worksheet
Set ws = Worksheets(2)
Application.ScreenUpdating = False
For Each c In Selection
For i = 1 To Len(c)
str = Mid(c, i, 1)
If WorksheetFunction.CountIf(ws.Columns(1), c.Characters(Start:=i, Length:=1) _
.Font.ColorIndex) = 0 And c.Characters(Start:=i, Length:=1).Font.ColorIndex <> xlAutomatic Then
ws.Cells(Rows.Count, 1).End(xlUp).Offset(1) = _
c.Characters(Start:=i, Length:=1).Font.ColorIndex
End If
Next i
ws.Cells(Rows.Count, 2).End(xlUp).Offset(1) = WorksheetFunction.Count(ws.Columns(1))
ws.Columns(1).Clear
Next c
ws.Cells(Rows.Count, 2).End(xlUp).Offset(1) = WorksheetFunction.Count(ws.Columns(1))
ws.Columns(1).Clear
MsgBox ("3色使用セルは" & WorksheetFunction.CountIf(ws.Columns(2), 3) & "個です。")
ws.Columns(2).Clear
Application.ScreenUpdating = True
End Sub

※　セル内のフォント色は「自動」以外の物を数えるようにしてみました。
※　上記コードは「3色」の場合のコードですので、2色の場合は
＞MsgBox ("3色使用セルは" & WorksheetFunction.CountIf(ws.Columns(2), 3) & "個です。")
の行を
＞MsgBox ("2色使用セルは" & WorksheetFunction.CountIf(ws.Columns(2), 2) & "個です。")

に変更してマクロを実行してみてください。

以上、参考になれば良いのですが・・・m(_ _)m

お礼

ご教授ありがとうございます。

やってみました！
これはこれで面白いですね！

なのですが、すいません。
その出てきた数字をさらに集計しまとめなければいけないので、データとして張り付いていないとだめなのです。。。

でも、ありがとうございました。。。

回答No.5

kmetu

> 今までのを消して上記を入れてみましたが、、、
>
> 今まで出来ていた1色のところも0になりました。
> 3色のところも０になりました。。。

うーん…こちらで適当なデータを入れて試したら指定色の文字数分の数値がでるのですが…
具体的にどのようなデータなのでしょうか。

全部は無理としても

D10,D8,D29,D49,D51,D57

のデータだけでも示せますでしょうか。

お礼

>例えば同一セル内で

分かりにくいので訂正。

セルが3個あって、1個のセル内に3つの数字があり、その3つの数字に色がついています。

補足

再度ありがとうございます。

Dの縦欄は、セル内背景色を分けているのと、文字色は1色です。
（なので、背景色ごとのセル分けで集計するための問１でした）

Eの縦欄は背景色は無くて全てのセルに(1)(2)(3)数字が3個あり、その内1位なら赤、2位なら青、3位ならピンク、それ以外は黒と入力と文字色分けは手入力です。

E欄の統計を取る際に、例えば同一セル内で

(1)(2)(3)（左から、赤・黒・青）
(1)(2)(3)（左から、黒・黒・赤）
(1)(2)(3)（左から、青・赤・青）

これの回答を
赤　3個
青　3個
ピンク　0個

というような集計をしたくて、ご相談しました。。。
最初からセルを分けてれば問題は無かったのでしょうが、そこまで気が回りませんでした。。。
セル分けをするとなると、もう膨大な量のデータになりそうなので、、、
現在手入力で数えてますが、その内間違えそうですｗ

ちなみに標準モジュールに下記コードを追加して両方走らせると、数値が正しく無いと出て表示自体が全部壊れてしまいました。。。

回答No.4

kmetu

もう一点は

Function SpecialCell(targetRange As Range, _
intColor As Integer) As Integer
'赤は3，緑は4，青は5，黄は6
Dim myCell As Range

For Each myCell In targetRange

For i = 1 To Len(myCell.Value)
If myCell.Characters(Start:=i, Length:=1).Font.ColorIndex = intColor Then
SpecialCell = SpecialCell + 1
End If
Next
Next
End Function

というコードでいかがでしょうか。

補足

ご教授ありがとうございます。

今までのを消して上記を入れてみましたが、、、

今まで出来ていた1色のところも0になりました。
3色のところも０になりました。。。

=SpecialCell(D5:D125,3)（1色のところ）
=SpecialCell(E5:E125,3)（3色のところ）

呼び出す引数の書き方がおかしいのでしょうか？

またご教授下さい。よろしくお願いいたします。

回答No.3

Cor_moriyan

このマクロは、ご自身で作成されたものですか？

> =SpecialCell(D10,D8,D29,D49,D51,D57,3)

Functionで定義している引数が２つ(targetRange As Range, intColor As Integer)しかないのに、それ以上書いてもエラーになるだけです。上記の様な指定をしたいなら、マクロを修正するしかありません。

> セル内に複数の色つき文字がある場合

マクロ内では、セル全体の文字書式(.Font.ColorIndex)しか判定していませんので、これもマクロを修正しないとダメです。

ご質問の内容は「どういう風に数式をいれればよいのでしょうか？」なので、セルに入れる数式の方法ですが。。。　残念ながら、回答としては「質問者さんのやりたい事が出来るマクロでは無い」です(^^;

マクロを直すとすれば、こういう感じでしょうか。

Function SpecialCell(RangeString As String, intColor As Integer) As Integer
　　'赤は3，緑は4，青は5，黄は6
　　Dim TargetRange As Range
　　Dim myCell　　　As Range
　　Dim bolFlag　　 As Boolean
　　Dim intIDX　　　As Integer

　　Set TargetRange = ActiveSheet.Range(RangeString)

　　For Each myCell In TargetRange
　　　　bolFlag = False
　　　　If myCell.Font.ColorIndex = intColor Then bolFlag = True
　　　　If myCell.Interior.ColorIndex = intColor Then bolFlag = True
　　　　If myCell.Value <> "" Then
　　　　　　For intIDX = 1 To Len(myCell.Value)
　　　　　　　　If myCell.Characters(intIDX, 1).Font.ColorIndex = intColor Then bolFlag = True
　　　　　　Next
　　　　End If

　　　　If bolFlag Then SpecialCell = SpecialCell + 1
　　Next

End Function

動作確認してませんが(^^;
=SpecialCell("D10,D8,D29,D49,D51,D57",3)
のように、検査したいセルのアドレスをダブルクォーテーション「"」で囲んで下さい。

補足

回答ありがとうございます。

>このマクロは、ご自身で作成されたものですか？

いえ、ほとんど素人ですので、ググッてググッてようやく見つけたマクロをいれてます。。。

第(1)の問いはNO２さんの括弧で囲む方法でいけました。

第(2)に関しては、教えていただいたマクロを今まで書いてあったのを消して再計算してみましたら、、、
今まで、=SpecialCell(D5:D125,3)
で出てきたところも０となってしまいできませんでした。。。

現状、セル内に1色の文字がある項目の計算は
=SpecialCell(D5:D125,3)
で出来てます。

セル内に1色～3色の文字がある項目の計算ができません。

（両方計算する必要があり、現在3色ある部分は目視計算）

またご教授いただければ幸いです。

回答No.2

kmetu

=SpecialCell((D10,D8,D29,D49,D51,D57),3)

セルの指示を括弧で囲むといけますね。

お礼

ありがとうございます！
括弧で囲むとすんなりいきました！

助かりました！