[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『範囲内に赤色せるがあればNG,以外はOKを表示したい』（坂田）
最終列と行はその都度変わる範囲内に
赤色のセルがあればA2に"NG"、
それ以外であればA3に"OK"を表示したいです。
ご教示頂けませんでしょうか。
＜ 使用 Excel：Microsoft365、使用 OS：Windows10 ＞
範囲を仮にB1:D10とします。赤い色のついたセルをF1とします。
以下のマクロをコピーします。
Option Explicit
Function CountColor(r As Range, c As Range) As Long
Dim cell As Range
Dim count As Long
For Each cell In r
If cell.Interior.Color = c.Interior.Color Then
count = count + 1
End If
Next
CountColor = count
End Function
A2に=if(CountColor(B1:D10,F1)>0,"NG","")
A3に=if(A2="","OK","")
こんなのでどうでしょうか？
（ゆたか） 2023/10/17(火) 16:27:48
よろしくお願いいたします。
（坂田） 2023/10/17(火) 16:40:57
それはともかく。。。
A2に=if(CountColor(B1:D10,F1)>0,"NG","OK")
とすれば、一つのセルでいけます。
（ゆたか） 2023/10/17(火) 16:44:18
今更なのですが、セルに計算式を入れるのではなくマクロで対応は難しいのでしょうか。
マクロボタンを配置したいと思っているのですが･･･
また範囲も都度変わるのでできれば、直接セルを指定せずに組めたらと思います。
わがままばかり申し訳ないです。
（坂田） 2023/10/17(火) 16:54:12
色も赤で決まっているのであれば、値をコード中に入れることもできます。
（ゆたか） 2023/10/17(火) 17:03:50
よければコードを勉強させてもらえると幸いです。
よろしくお願いいたします。
（坂田） 2023/10/17(火) 17:05:38
>色のついたセルが増減しても、自動で再計算されない。。。 >Application.VolatileをFunctionの直後に入れたら良いらしい。。。 >入れてみましたが、うまく行きませんでした(~~;
とりあえず、この件について。
セルのバックグラウンドカラーを変える行為は再計算の契機とはならないようです。
そのシートのいずれかのセルに入力、変更が行われた場合には、再計算が行われます。
（ゆたか） 2023/10/18(水) 08:42:51
＞最終列と行はその都度変わる範囲内に
この範囲をどう特定するかが問題です。 都度、ユーザーが指定するのか、プログラムで自動的に判定するのか。
もし自動的に判定する必要があるなら、その特定ルールを説明してください。
（半平太） 2023/10/18(水) 09:33:10
選択範囲を入力するタイプです。マウスで範囲を選ぶこともできます。
Sub CountColor1()
Dim area As Range, cell As Range
Dim count As Long
On Error GoTo ErrExit
Set area = Application.InputBox(Prompt:="範囲を選択してください。", Type:=8)
For Each cell In area
If cell.Interior.ColorIndex = 3 Then '赤を指定
count = count + 1
End If
Next
If count = 0 Then
MsgBox "OK"
Else
MsgBox "NG"
End If
ErrExit:
End Sub
もし、A1など特定のセルは必ず表に含まれ、表にはデータが入っていて、
空白行、空白列で区切られているなら、以下のようなコードも使えます。
Sub CountColor2()
Dim area As Range, cell As Range
Dim count As Long
On Error GoTo ErrExit
Set area = Range("A1").CurrentRegion 'A1セルから表範囲を自動で選択
area.Select '特に必要ないが選択範囲を明示
For Each cell In area
If cell.Interior.ColorIndex = 3 Then '赤を指定
count = count + 1
End If
Next
If count = 0 Then
MsgBox "OK"
Else
MsgBox "NG"
End If
ErrExit:
End Sub
何かエラーがあれば、とりあえず終了します（笑）
（ゆたか） 2023/10/18(水) 11:29:52
回答じゃなく完全な脱線話でアレなんですが・・・
>> 勉強させてもらえると幸い なんて言われると「つい」語りたくなっちゃってw ^^;
この手の課題で自分の中では割と長期の宿題(棚上げとも云う)にしてしまっている事があります。 (たいへん実用性に乏しい課題なので、なかなか真面目に取り組む気になれないだけですけど... ^^;)
例えば、
Function CreateInteriorColorList(Optional ByVal ChkArea As Range) As Object
Rem 引数[ChkArea]に含まれる塗りつぶし色の一意リストを作って返す関数
Rem 戻値---KeyがCOLORREF値(またはXlColorIndex定数)で値がRangeのScripting.Dictionary
・・・の様な汎用関数を考える場合、
引数[ChkArea]に列全体(行全体ならまだしも)を指定される事を想定すると、 各セルの塗りつぶし色を総当たりで調べるのは、処理速度の観点から出来れば避けて通りたい訳ですが、 かと言って、 調査対象をUsedRange内に限定してしまう訳にも行きません。 値や数式とは違い、色付きセルはUsedRange外にも存在し得るからです。
総当たりの回避策として、
矩形単位や列単位・行単位で全てのセルが同じ色か否かが↓これで確認出来ますから、
If IsNull(調査単位.Interior.ColorIndex) Then
Nullだった場合は(仕方なく)セル単位で確認する様な組み方も考えられます。
でも、 それだけでは結局総当たりになってしまうケースの遭遇率は依然として高そうです。 (例えばA列全体を黄色で塗って[A10]セルだけ色を消す。で、引数にA列全体を指定した場合等)
で、調査対象をUsedRange「内」と「外」で分割して考えてみてはどうだろうか? 少なくともUsedRangeの外側まで総当たりする必要は無い筈だよね? と思って、試しに素案を練っている途中で自分が何やってたのか見失ってしまい、現在に至ります。
ChkAreaの属するシートを4つのエリアに分割し、
1---.Range("A1", .UsedRange)
2---1の右
3---1の下
4---2の下(3の右でもよい)
ChkArea(内各Area毎)とのIntersect毎で調査する
1---列(or行)単位に調査し、Nullだった列(or行)はセル単位に再調査
2---Intersect内の1列目だけで同様に調査
3---Intersect内の1行目だけで同様に調査
4---Intersect内の先頭(TopLeft)セルだけで判断
だいたいの流れ
◇当該矩形内が複数色
├Y:列または行単位で調査
│◇縦方向に長い矩形
│├Y:列単位で調査
││◇当該列内が複数色
││├Y:セル単位で再調査して辞書に登録
││└N:列ごと辞書に登録
│└N:行単位で調査
│ ◇当該行内が複数色
│ ├Y:セル単位で再調査して辞書に登録
│ └N:行ごと辞書に登録
└N:矩形ごと辞書に登録
・・・ホントか? ホントにそれでいいのか?
Function CreateInteriorColorList(Optional ChkArea As Range) As Object
If ChkArea Is Nothing Then
If ActiveSheet Is Nothing Then Exit Function
Set ChkArea = ActiveWindow.RangeSelection
End If
Dim Dic As Object
Dim iArea As Range, a As Range, c As Range
Set Dic = CreateObject("Scripting.Dictionary")
If IsNull(ChkArea.Interior.ColorIndex) Then
Dim uRect As Range, UnUsedR As Range, UnUsedB As Range, UnUsedBR As Range, LastCell As Range
With ChkArea.Worksheet
Set uRect = .Range("A1", .UsedRange)
Set LastCell = .Cells(uRect.Rows.Count, uRect.Columns.Count)
If LastCell.Column < .Columns.Count Then
Set UnUsedR = .Range(.Cells(1, LastCell.Column + 1), .Cells(LastCell.Row, .Columns.Count))
If LastCell.Row < .Rows.Count Then Set UnUsedBR = .Range(LastCell.Offset(1, 1), .Cells(.Rows.Count, Columns.Count))
End If
If LastCell.Row < .Rows.Count Then Set UnUsedB = .Range(.Cells(LastCell.Row + 1, 1), .Cells(.Rows.Count, LastCell.Column))
End With
For Each iArea In ChkArea.Areas
If IsNull(iArea.Interior.ColorIndex) Then
Set a = Intersect(iArea, uRect)
If Not a Is Nothing Then
If IsNull(a.Interior.ColorIndex) Then
If a.Rows.Count > a.Columns.Count Then
CreateInteriorColorList_ChkColumns Dic, a
Else
CreateInteriorColorList_ChkRows Dic, a
End If
Else
CreateInteriorColorList_DicAdd Dic, a
End If
End If
Set a = Intersect(iArea, UnUsedR)
If Not a Is Nothing Then
If IsNull(a.Interior.ColorIndex) Then
For Each c In a.Rows
CreateInteriorColorList_DicAdd Dic, c
Next
Else
CreateInteriorColorList_DicAdd Dic, a
End If
End If
Set a = Intersect(iArea, UnUsedB)
If Not a Is Nothing Then
If IsNull(a.Interior.ColorIndex) Then
For Each c In a.Columns
CreateInteriorColorList_DicAdd Dic, c
Next
Else
CreateInteriorColorList_DicAdd Dic, a
End If
End If
Set a = Intersect(iArea, UnUsedBR)
If Not a Is Nothing Then
CreateInteriorColorList_DicAdd Dic, a
End If
Else
CreateInteriorColorList_DicAdd Dic, iArea
End If
Next
Else
CreateInteriorColorList_DicAdd Dic, ChkArea
End If
Set CreateInteriorColorList = Dic
End Function
Private Sub CreateInteriorColorList_ChkRows(d As Object, a As Range)
Dim r As Range
For Each r In a.Rows
If IsNull(r.Interior.ColorIndex) Then
Call CreateInteriorColorList_ChkColumns(d, r)
Else
CreateInteriorColorList_DicAdd d, r
End If
Next
End Sub
Private Sub CreateInteriorColorList_ChkColumns(d As Object, a As Range)
Dim c As Range
For Each c In a.Columns
If IsNull(c.Interior.ColorIndex) Then
Call CreateInteriorColorList_ChkRows(d, c)
Else
CreateInteriorColorList_DicAdd d, c
End If
Next
End Sub
Private Sub CreateInteriorColorList_DicAdd(d As Object, ByVal a As Range)
Dim k As Long
k = a(1).Interior.ColorIndex
If (k And &HFF000000) = 0 Then k = a(1).Interior.Color
If d.Exists(k) Then Set d(k) = Union(d(k), a) Else Set d(k) = a
End Sub
'**************************************************************************
Sub test()
Dim d As Object, v
Set d = CreateInteriorColorList()
If d.Count = 0 Then Exit Sub
For Each v In d.Keys
Debug.Print Hex(v), d(v).Address(False, False)
Next
End Sub
たまにはこういう「つまらぬ課題」に取り組んでみるのも面白いものです。 スミマセン、お邪魔しました〜 ^^;
（白茶） 2023/10/18(水) 21:55:14
今更ですが、範囲内に特定の色のセルがあるかないかを判定する（しかできない）マクロ
Sub sample()
Dim aCol As Range
For Each aCol In Range("A:H").Columns
Debug.Print aCol.Address; vbTab; HasColorCell(aCol, RGB(255, 0, 0))
Next
End Sub
Function HasColorCell(Rng As Range, ByVal Color) As Boolean
Dim aCell As Range
Application.FindFormat.Interior.Color = Color
With Rng
Set aCell = .Find(What:="", After:=.Cells(1, 1), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
MatchByte:=False, _
SearchFormat:=True)
End With
HasColorCell = Not (aCell Is Nothing)
End Function
（´・ω・`） 2023/10/23(月) 15:29:06
http://www.vbalab.sakura.ne.jp/vbaqa/c-board.cgi?cmd=ntr;tree=82205;id=excel
（MK） 2023/10/23(月) 15:56:22
おそらく同じ人だと思いますよ
さて、先ほどの Function HasColorCell は条件付き書式 の色だと対応できないですね
たぶんなんとなくですが、質問者さんの要望にあってない気がする （´・ω・`） 2023/10/23(月) 16:30:37
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.