書類の提出状況に合わせてセルを塗りつぶす（見える化）

昨日は、指定したコードが別の表にあるかどうかを確認し、それに関連する書類の提出状況を取得してみた。
infoment.hatenablog.com
今回一連の問い合わせをくださった方は、更に、

提出状況に対応する色でセルを塗りつぶして見える化したい

とのことだった。職場の勉強会では、皆さんこのような流れでマクロを作りこんでいった。
f:id:Infoment:20190218215854p:plain

例えば、書類の提出状況がこんな感じだったとする。
f:id:Infoment:20190218215942p:plain

塗りつぶしのルールは、以下の通り。

書類1	書類2	色
		なし
〇		青
	〇	赤
〇	〇	黄

そこで昨日のコードに、書類の提出状況取得と、それに対応する着色の部分を盛り込んでみた。

Sub test()
    Dim val As String
        val = Range("A1").Value
        
    ' Split関数で、改行コードを区切り文字として配列化し、
    ' 二つ目の要素を案件管理番号として取得する。
    Dim ControlNumber As String
        ControlNumber = Left(Split(val, vbLf)(1), 7)

    ' 書類提出状況管理テーブル。
    Dim Tb As ListObject
    Set Tb = Sheets("書類提出状況管理").ListObjects(1)
    
    ' 検索と塗りつぶし。
    Dim FindResult As Range
    Set FindResult = Tb.ListColumns("管理番号").DataBodyRange. _
                     Find(ControlNumber)
        If Not FindResult Is Nothing Then
            If FindResult.Offset(, 1) = "〇" And FindResult.Offset(, 2) = vbNullString Then
                Range("A1").Interior.Color = vbBlue
            ElseIf FindResult.Offset(, 1) = vbNullString And FindResult.Offset(, 2) = "〇" Then
                Range("A1").Interior.Color = vbRed
            ElseIf FindResult.Offset(, 1) = "〇" And FindResult.Offset(, 2) = "〇" Then
                Range("A1").Interior.Color = vbYellow
            End If
        End If
End Sub

勉強会では、まず一つのセルを決め打ちで作ってみた。上手くいったので、これをループさせてみた。

Sub test()
    ' 書類提出状況管理テーブル。
    Dim Tb As ListObject
    Set Tb = Sheets("書類提出状況管理").ListObjects(1)

    Dim val As String
    Dim ControlNumber As String
    Dim FindResult As Range
    
    Dim r As Range
    
    For Each r In Selection
        If r.Value <> vbNullString Then
            val = r.Value
            ControlNumber = Left(Split(val, vbLf)(1), 7)
            
            ' 検索
            Set FindResult = Tb.ListColumns("管理番号").DataBodyRange. _
                             Find(ControlNumber)
                If Not FindResult Is Nothing Then
                    If FindResult.Offset(, 1) = "〇" And FindResult.Offset(, 2) = vbNullString Then
                        r.Interior.Color = vbBlue
                    ElseIf FindResult.Offset(, 1) = vbNullString And FindResult.Offset(, 2) = "〇" Then
                        r.Interior.Color = vbRed
                    ElseIf FindResult.Offset(, 1) = "〇" And FindResult.Offset(, 2) = "〇" Then
                        r.Interior.Color = vbYellow
                    End If
                End If
        End If
    Next
End Sub