Excel-VBA セルに背景色を

セルのデータに応じた背景色をつける事はよく行われます。
しかし、そのセル数が1000以上あった場合、その作業は大変です。
データに応じた背景色を個々に着色するのは、CTRLキーを併用しても
10色以上ともなれば重労働です。
こんな時はVBAを使います。
Loopでセルの個別の値を読み取り、該当する背景色で着色します。
Sourceは、50人の一ヶ月間（約1500-1550）のセルを、二段階のLoopで
回し、その処理を行っています。
様々な判定基準があるので、前後関係も検証しています。

Sub SKD_Count()
'
' SKD_Count Macro

' 月間予定表の色付け＆集計

'
Sheets("SKD1").Select
Range("C10:AG59").Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("A1").Select

Dim Y_n As Long, X_n As Long
Dim i As Long, j As Long, k As Long
Dim Nor_n As Long, Nit_n As Long, Hol_n As Long, Mon_n As Long, Sus_n As Long
Dim Zer_n As Long
Dim W_cF_n As Single, W_cB_n As Single
Dim PoPF_n As Long, PoPB_n As Long

Dim W_c As String, W_c2 As String

Dim vega, vega_date, vega_time, U_Nam As String

U_Nam = Environ("USERNAME")

vega = Now()

vega_date = Mid(vega, 6)

vega_time = Right(vega, 8)

For i = 3 To 33

For j = 10 To 59

W_c = Cells(j, i)

'+の前後の数値を取り出す

If W_c = "0" Or W_c = "*" Or W_c = "Y" Or W_c = "=" Or W_c = "Q" Or W_c = "S" Or W_c = "S" Or W_c = "T" Then

If W_c = "0" Then Zer_n = Zer_n + 1

Else

PoPF_n = InStr(W_c, "+") '+位置を検出前方
PoPB_n = InStrRev(W_c, "+") '+位置を検出後方
PoPB_n = Len(W_c) - PoPB_n + 1 ' Rightのために位置算出

If PoPF_n = 0 And PoPB_n = 1 Then

Else

W_cF_n = Val(Left(W_c, PoPF_n))
W_cB_n = Val(Right(W_c, PoPB_n))

'Debug.Print PoPF_n & ":" & PoPB_n & "-" & Len(W_c)

'Debug.Print W_cF_n & ":" & W_cB_n

End If

End If

Select Case W_c '勤務状態で色を決める

Case "*"

Cells(j, i).Interior.ColorIndex = 41

Hol_n = Hol_n + 1

Case "="

Cells(j, i).Interior.ColorIndex = 8

Hol_n = Hol_n + 1

Case "Y"

Cells(j, i).Interior.ColorIndex = 17

Hol_n = Hol_n + 1

Case "Q"

Cells(j, i).Interior.ColorIndex = 3

Nit_n = Nit_n + 1

Case "R"

Cells(j, i).Interior.ColorIndex = 27

Nit_n = Nit_n + 1

Case "S"

Cells(j, i).Interior.ColorIndex = 44

Nit_n = Nit_n + 1

Case "T"

Cells(j, i).Interior.ColorIndex = 46

Nit_n = Nit_n + 1

End Select

If Left(W_c, 2) = "0+" Then

Cells(j, i).Interior.ColorIndex = 26

Nit_n = Nit_n + 1

End If

If Left(W_c, 2) = "16" And W_cB_n > 4 Then

Cells(j, i).Interior.ColorIndex = 26

Nit_n = Nit_n + 1

End If

If Left(W_c, 2) = "18" And W_cB_n > 4 Then

Cells(j, i).Interior.ColorIndex = 26

Nit_n = Nit_n + 1

End If

If Val(Left(W_c, 1)) < 8 And Val(Left(W_c, 1)) > 5 Then

Cells(j, i).Interior.ColorIndex = 43

Mon_n = Mon_n + 1

End If

If Val(Left(W_c, 2)) >= 16 And Val(Left(W_c, 2)) + Val(Right(W_c, 1)) <= 20 Then

Cells(j, i).Interior.ColorIndex = 17

Sus_n = Sus_n + 1

End If

Next j

Nor_n = 50 - Nit_n - Hol_n - Mon_n - Sus_n - Zer_n

Cells(3, i) = Nor_n
Cells(4, i) = Nit_n
Cells(5, i) = Hol_n
Cells(6, i) = Mon_n
Cells(7, i) = Sus_n
' Cells(8, i) = Zer_n
' Cells(9, i) = Zer_n + Sus_n + Mon_n + Hol_n + Nit_n + Nor_n

Nor_n = 0
Nit_n = 0
Hol_n = 0
Mon_n = 0
Sus_n = 0
Zer_n = 0

Next i

Range("A2") = vega_date
Range("B2") = vega_time

End Sub

わかお　かずまさ

VegaSystems