エクセルVBAボタンで条件色指定

質問

お世話になります
都道府県別に訪問者と数量に色を一括に塗りたいのですが（セル）
たとえばAボタンBボタンCボタンを3つ作成し
Aボタンを押すと東京、大阪は青色に
Bボタンは名古屋、札幌を黄色に
Cボタンは九州、四国で赤色に
｜訪問者｜数量｜場所｜
｜太郎　｜1121｜大阪｜
｜四郎　｜3321｜四国｜
｜山田　｜3000｜札幌｜
｜斉藤　｜2000｜東京｜
｜無色　｜1000｜未定｜
上記Aボタンを押すと大阪と東京にいる訪問者と数量に青色を塗りたいのです。
Bなら札幌の山田と3000に黄色とセルの色を付けたい
2000列ぐらいあるので一括で希望です。
わかる方ご教授よろしくお願い致します

回答No.1

fumufumu_2006 · ベストアンサー

こんなのではどうでしょう？
訪問者,数量,場所が各々A,B,C列だとします。
A,B,CボタンをCommandButton1,CommandButton2,CommandButton3とします。
訪問者と数量の色を変えていますが、場所の色も変える場合は、Resize(1, 2)をResize(1, 3)にしてください。
チェックの方法は、カンマで囲まれた文字があるかどうかでチェックしています。

Private Sub CommandButton1_Click()
checkData "東京,大阪", vbBlue
End Sub

Private Sub CommandButton2_Click()
checkData "名古屋,札幌", vbYellow
End Sub

Private Sub CommandButton3_Click()
checkData "九州,四国", vbRed
End Sub

Private Sub checkData(place As String, color As Long)
Dim r As Long
For r = 2 To Cells(Rows.Count, 3).End(xlUp).Row
If InStr("," & place & ",", "," & Cells(r, 3) & ",") > 0 Then
Cells(r, 1).Resize(1, 2).Font.color = color
Else
Cells(r, 1).Resize(1, 2).Font.color = vbBlack '対象外の色を黒にする場合
End If
Next
End Sub

回答No.2

Wendy02

こんにちは。

一括で塗るという部分にこだわってみました。

サブルーチンの
　FilterSeting 範囲, 色番号,　地域名1, 地域名2, ....

というように入れます。ご質問者さんは、色番号(ColorIndex)については、ご存知だと思いますから、詳しくは説明いれません。必要なら、ヘルプをごらんになってください。色塗りは、フォントの場合は、原色で、塗りつぶしの場合は、パステルカラーが良いようです。

地域名の引数のパラメータは、30個程度までは可能だったと思います。

行数は、数千程度なら、まったくストレスを感じせずに塗ることが可能だと思います。

'シートモジュールのみ
'--------------------------------------------------------

Private Sub CommandButton1_Click()
　FilterSeting Range("A1").CurrentRegion, 34, "東京", "大阪"
End Sub
Private Sub CommandButton2_Click()
　FilterSeting Range("A1").CurrentRegion, 36, "名古屋", "札幌"
End Sub
Private Sub CommandButton3_Click()
　FilterSeting Range("A1").CurrentRegion, 7, "九州", "四国"
End Sub
Private Sub FilterSeting(rng As Range, iColor As Integer, ParamArray args())
　　Dim arg_tmp(1) As String
　　Dim n As Integer
　　Dim k As Variant
　　Dim j As Integer
　　Dim i As Integer

　　k = UBound(args())
　　Application.ScreenUpdating = False

　　With rng
　　　　 .Interior.ColorIndex = xlNone '色戻し

　　　　For n = 0 To k Step 2
　　　　　　'パラメータの代入
　　　　　　Do Until (k < 0) Or (j > 1)
　　　　　　　　arg_tmp(j) = args(i)
　　　　　　　　k = k - 1
　　　　　　　　i = i + 1
　　　　　　　　j = i
　　　　　　Loop
　　　　　　'オートフィルタによる色づけ
　　　　　　If ActiveSheet.AutoFilterMode Then
　　　　　　　　.AutoFilter
　　　　　　End If
　　　　　　.AutoFilter Field:=3, _
　　　　　　Criteria1:="=" & arg_tmp(0), _
　　　　　　Operator:=xlOr, _
　　　　　　Criteria2:="=" & arg_tmp(1)
　　　　　　On Error Resume Next
　　　　　　.Offset(1, 1).Resize(.Rows.Count - 1, 2).SpecialCells(xlCellTypeVisible) _
　　　　　　.Interior.ColorIndex = iColor 'パターン・色付け
　　　　　　'.Font.ColorIndex = iColor　'フォント・色づけ
　　　　　　On Error GoTo 0
　　　　　　.AutoFilter

　　　　　　'カウント消去
　　　　　　If j > 1 Then
　　　　　　　　j = 0
　　　　　　　　Erase arg_tmp()
　　　　　　End If
　　　　Next n
　　End With
　　Application.ScreenUpdating = True
End Sub