[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『条件付き書式で設定された背景色のセルをカウントする方法VBA』（マサ）
条件付き書式で設定された背景色（赤）のセルをカウントするVBAをご教授いただければ幸いです。
Function ColorCnt(rng As Range) As Double
Dim RngObj As Range
'指定されたセル範囲の分だけ、処理を繰り返す。
For Each RngObj In rng
'セルの色が、赤色の場合
If RngObj.Interior.Color = RGB(255, 0, 0) Then
'カウントアップする
ColorCnt = ColorCnt + 1
End If
Next
End Function
上記ではカウントされませんでした。よろしくお願いいたします。
＜ 使用 Excel：Excel2016、使用 OS：Windows10 ＞
条件付き書式でついている色も取得したいときは Range(～).DisplayFormat.Interior.Color で。 なお、これは条件付き書式、通常の背景色の区別なしにその時点でセルに表示されている色を取得する。 （ねむねむ） 2019/07/17(水) 17:21
（マナ） 2019/07/17(水) 21:42
うっかりしていた。 もしユーザー設定関数として使うのであればDisplayFormatは使えない。 これはDisplayFormatの仕様のため、どうしようもない。 （ねむねむ） 2019/07/18(木) 06:36
ちょっと確認。
＞条件付き書式で設定された背景色（赤）
１．赤のケースだけ決め打ちになっていますが、それでいいんですね？
２．具体的にどんな条件ですか？ ※その条件でカウントする数式を作れば、色を判別しなくても対応できる可能性があります。
３．参考までにお聞きしますが、条件付き書式を設定する時、 「数式を使用して、書式設定するセルを決定」からやりましたか？
（半平太） 2019/07/18(木) 07:58
条件付き書式で設定された背景色（赤）のセル数（列ごとに）をカウントする方法
でお願いできますでしょうか？
VBAにはこだわっておりません。
よろしくお願いいたします。
（マサ） 2019/07/18(木) 10:39
Sub test8()
Dim mySht As Worksheet
Dim myClm As Range
Dim myCell As Range
Dim i As Long
Dim j As Long
Set mySht = ThisWorkbook.Worksheets("Sheet3")
i = 0
For Each myClm In mySht.UsedRange.Columns
i = i + 1
j = 0
For Each myCell In myClm.Cells
If myCell.DisplayFormat.Interior.Color = RGB(255, 0, 0) And _
myCell.Interior.Color <> RGB(255, 0, 0) Then
j = j + 1
End If
Next
MsgBox i & "列目" & j & "個"
Next
End Sub
（渡辺ひかる） 2019/07/18(木) 11:45
A列 B列 C列
あ 赤色 赤色
い 赤色
う 赤色 赤色
え 赤色
合計 ２ １ ３
上記のような感じでシートがあります。
合計の欄に列の赤色の数が（条件付き書式で設定された背景色（赤））カウント（例：２、１、３）されるようにできますか。
よろしくお願いいたします。
（マサ） 2019/07/18(木) 12:04
＞条件付き書式で設定された背景色（赤）のセル数（列ごとに）をカウントする方法
では、これに答えていただくといいかもです。 ↓ ＞ ３．参考までにお聞きしますが、条件付き書式を設定する時、 ＞ 「数式を使用して、書式設定するセルを決定」からやりましたか？
（半平太） 2019/07/18(木) 16:20
＞条件付き書式で設定された背景色（赤）のセル数（列ごとに）をカウントする方法
では、これに答えていただくといいかもです。 ↓ ＞ ３．参考までにお聞きしますが、条件付き書式を設定する時、 ＞ 「数式を使用して、書式設定するセルを決定」からやりましたか？
→「数式を使用して、書式設定するセルを決定」でやりました。
よろしくお願いいたします。
（マサ） 2019/07/19(金) 15:17
＞→「数式を使用して、書式設定するセルを決定」でやりました。
それなら、
１．後記マクロを標準モジュールにコピペする。
２．B5セル =SUMPRODUCT(N(FmtCondIntrCLRAnyVer(B1:B4)=255))+TODAY()*0
３．右にコピー(D5セルまで)
<結果図> 行 __A__ _B_ _C_ _D_ 1 あ ｂ ｃ ｄ 2 い ｂ ｃ ｄ 3 う ｂ ｃ ｄ 4 え ｂ ｃ ｄ 5 合計 2 1 3
'標準モジュールに貼り付けるマクロ ’↓ #Const xlsm12 = 12 Const msgXlExpression = "「数式を使用して・・」以外の設定有り"
Public Function FmtCondIntrCLRAnyVer(rngToProc As Range)
Dim rr As Long, cc As Long 'アクティブセルとのオフセット差
Dim RRR As Long, CCC As Long 'XLSM用オフセット値
Dim strFmla As String '修正後条件式
Dim TrueOrFalse As Variant
Dim fmtCndton As FormatCondition
Dim eachCel As Range
Dim result As Long
Dim Results() As Variant
Dim NN As Long, MM As Long
Dim rngRow As Range
Set rngToProc = Intersect(rngToProc, rngToProc.Parent.UsedRange)
If ValueOfFCtypeExists(rngToProc) Then '「数式を使用して・・」モードのみかチェック
FmtCondIntrCLRAnyVer = msgXlExpression
Exit Function
End If
ReDim Results(1 To rngToProc.Rows.Count, 1 To rngToProc.Columns.Count) As Variant
NN = 0
For Each rngRow In rngToProc.Rows
NN = NN + 1
MM = 0
For Each eachCel In rngRow.Cells
rr = ActiveCell.Row - eachCel.Row
cc = ActiveCell.Column - eachCel.Column
MM = MM + 1
result = 0
For Each fmtCndton In eachCel.FormatConditions
#If xlsm12 >= 12 Then
RRR = ActiveCell.Row - fmtCndton.AppliesTo.Row
CCC = ActiveCell.Column - fmtCndton.AppliesTo.Column
#End If
strFmla = fmtCndton.Formula1
With Application
strFmla = .ConvertFormula(fmtCndton.Formula1, _
xlA1, xlR1C1, , eachCel.Offset(rr, cc))
#If xlsm12 >= 12 Then
strFmla = .ConvertFormula(strFmla, _
xlR1C1, xlA1, , eachCel.Offset(RRR, CCC))
#Else
strFmla = .ConvertFormula(strFmla, xlR1C1, xlA1, , eachCel)
#End If
End With
TrueOrFalse = Evaluate(strFmla) '条件式を評価
If Not IsError(TrueOrFalse) Then
If TrueOrFalse Then
#If xlsm12 >= 12 Then
If Not IsNull(fmtCndton.Interior.Color) Then
result = fmtCndton.Interior.Color
Exit For
ElseIf fmtCndton.StopIfTrue Then '停止条件がTrueならこれ以上追及しない
result = 0
Exit For
End If
#Else '停止条件不考慮(Trueになったので、いずれにしてもExitForとなる）
If Not IsNull(fmtCndton.Interior.Color) Then
result = fmtCndton.Interior.Color
Else
result = 0
End If
Exit For
#End If
End If
End If
Next
Results(NN, MM) = result
Next
Next
FmtCondIntrCLRAnyVer = Results
End Function
Private Function ValueOfFCtypeExists(rngToProc As Range) As Boolean
Dim aCell As Range
Dim FC As FormatCondition
ValueOfFCtypeExists = False
For Each aCell In rngToProc
For Each FC In aCell.FormatConditions
If Not FC.Type = xlExpression Then
ValueOfFCtypeExists = True
Exit Function
End If
Next
Next
End Function
（半平太） 2019/07/19(金) 16:48
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.