VBAだけで条件付き書式 - SO NOTE そうのて (；^ω^)

Excelで、セルに条件に合致する値が入力されたら設定した書式を適用させる
っていう、所謂「条件付き書式」って機能があるのは、Excelをそれなりに
使ってる人は知ってると思います。
ただ、この条件付き書式を多くのセルに設定すると、ファイルがすごく重たくなるみたいです。
これをなんとか出来んかという要望がきたんで、VBA版条件付き書式を作ってみました。

コード

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim shIni    As Worksheet
    Dim vntCol   As Variant
    Dim strCol   As String
    Dim i        As Long
    Dim rngI     As Range
    
    Dim lngRow   As Long
    Dim rngFind  As Range
    Dim strAddr  As String
    Dim c        As Range
    
    'イベント監視を一旦停止
    Application.EnableEvents = False

    'iniシートの存在チェック
    On Error Resume Next
    Set shIni = ThisWorkbook.Worksheets("ini")
    If Err.Number <> 0 Then
        MsgBox "iniシートが見つからない為、実行できません！", vbExclamation
        GoTo Finally
    End If
    On Error GoTo 0
    
    On Error GoTo ErrHandler
    
    With shIni
        vntCol = .Range("A2:A" & .Cells(65536, "A").End(xlUp).Row)
    End With
    
    strCol = ""
    For i = LBound(vntCol, 1) To UBound(vntCol, 1)
        strCol = strCol & vntCol(i, 1) & ":" & vntCol(i, 1) & ","
    Next i
    strCol = Left(strCol, Len(strCol) - 1)

    Set rngI = Application.Intersect(Target, Me.Range(strCol))
    
    If rngI Is Nothing Then GoTo Finally
    
    For Each c In rngI
        strCol = Split(c.Address, "$")(1)
        Set rngFind = shIni.Columns(1).Find(What:=strCol, LookIn:=xlValues, LookAt:=xlWhole)
        strAddr = rngFind.Address
        Do
            If CStr(c.Value) = CStr(rngFind.Offset(, 1).Value) Then
                rngFind.Offset(, 2).Copy
                Me.Range(rngFind.Offset(, 3).Value & c.Row & ":" & rngFind.Offset(, 4).Value & c.Row). _
                        PasteSpecial xlPasteFormats
                Exit Do
            Else
                shIni.Range("F1").Copy
                Me.Range(rngFind.Offset(, 3).Value & c.Row & ":" & rngFind.Offset(, 4).Value & c.Row). _
                        PasteSpecial xlPasteFormats
            End If
            Set rngFind = shIni.Columns(1).FindNext(rngFind)
        Loop While Not rngFind Is Nothing And rngFind.Address <> strAddr
    Next c
    Application.CutCopyMode = False

Finally:
    On Error Resume Next
    Set c = Nothing
    Set rngFind = Nothing
    Set shIni = Nothing
    Application.EnableEvents = True
    Exit Sub

ErrHandler:

    With Err
        MsgBox "エラーが発生しました" & vbCrLf & .Number & vbCrLf & .Description, vbCritical
    End With
    Resume Finally

End Sub

もっといいロジックがあるんだろうけど、自分の頭では思い付かないです...

使い方

1.まずは↑のコードを、条件付き書式を適用したいシートのシートモジュールに貼り付けます。
2.次に、シート名「ini」っていうシートを対象Bookに追加します。
3.iniシートを下図の要領で設定します。※各設定列を間違えない様にして下さい。

<追記>↑の図のE列の見出しの文言間違ってますね。。。「書式適用終了列」が正です。（;´Д｀）