クラスモジュールに移してみる - Infomentのブログ～Excel VBA奮闘記～

昨日は、書類の提出状況に対応する色でセルを塗りつぶして見える化するプロシージャについて、その内容を幾つかのプロシージャに分割してみた。
infoment.hatenablog.com
今日は更に、その幾つかをクラスモジュールに委ねてみる。
f:id:Infoment:20190220220021p:plain
まず、クラスモジュールを一つ作成する。名前は、お好みに合わせて。私はgoogle翻訳で出た「Document Submission Status」（書類提出状況）を、そのまま使用することにする。

クラスモジュール（DocumentSubmissionStatusClass）

使う側にしてみれば、途中経過は多分「あまり興味がない」。とにかくセルを渡したら、内容に対応する色で塗りつぶしてくれれば、それでいい訳で。

色を決めたり、それを辞書に登録するところは、ユーザーから見えなくてもいい。Privateにしてしまおう。

Option Explicit

' 書類提出状況別に、対応する色を返す関数。
Private Function GetColor(doc_1 As String, doc_2 As String) As Long
    If doc_1 = "〇" And doc_2 = vbNullString Then
        GetColor = vbBlue
    ElseIf doc_1 = vbNullString And doc_2 = "〇" Then
        GetColor = vbRed
    ElseIf doc_1 = "〇" And doc_2 = "〇" Then
        GetColor = vbYellow
    Else
        GetColor = vbWhite
    End If
End Function

' セルの記載内容から、管理番号を抽出して返す関数。
Private Function GetControlNumber(target As Range) As String
    If target.Value = vbNullString Then
        GetControlNumber = vbNullString
    Else
        GetControlNumber = Left(Split(target.Value, vbLf)(1), 7)
    End If
End Function

' 各管理番号について、提出書類の状況に対応する色を返す関数。
Private Function GetColorDict() As Dictionary
    ' 書類提出状況管理テーブル。
    Dim Tb As ListObject
    Set Tb = Sheets("書類提出状況管理").ListObjects(1)
    
    Dim Dict As Dictionary
    Set Dict = New Dictionary
    
    Dim doc(1 To 2) As String
    
    Dim r As Range
        For Each r In Tb.ListColumns("管理番号").DataBodyRange
            doc(1) = r.Offset(, 1)
            doc(2) = r.Offset(, 2)
            Dict(r.Value) = GetColor(doc(1), doc(2))
        Next
        
    Set GetColorDict = Dict
End Function

' 処理範囲を受け取って、各セルに着色するプロシージャ。
Public Sub VisualizeSubmissionStatus(target_range As Range)
    Dim r As Range
    Dim Dict As Dictionary
    Set Dict = GetColorDict
    Dim ControlNumber As String
        For Each r In target_range
            ControlNumber = GetControlNumber(r)
            If Dict.Exists(ControlNumber) Then
                r.Interior.Color = Dict(ControlNumber)
            End If
        Next
End Sub

標準モジュール

ほとんどをクラスモジュールに委ねてしまったので、こちらは閑散としている。

Sub test()
    Dim DSS As DocumentSubmissionStatusClass
    Set DSS = New DocumentSubmissionStatusClass
    
    Call DSS.VisualizeSubmissionStatus(Selection)
End Sub