EXCEL VBA セルの半分を色を塗る、セルを斜めに塗る、（応用）条件付き書式のデータバーの代わり

VBAでセルの半分だけ色を塗りたいという質問が、ヤフー知恵袋などに記載されていましたが図形を使用した方法のみしか提示されていなかったので、メモと共有。

Sub A()
    '縦に2分割
    With Cells(1, 1).Interior
        .Pattern = xlPatternLinearGradient
        With .Gradient
        .Degree = 0
            With .ColorStops
                .Clear
                .Add(0).Color = vbRed
                .Add(0.5).Color = vbRed
                .Add(0.5 + 0.001).Color = vbWhite
                .Add(1).Color = vbWhite
            End With
        End With
    End With

    '斜めに2分割
    With Cells(2, 1).Interior
        .Pattern = xlPatternLinearGradient
        With .Gradient
        .Degree = 45
            With .ColorStops
                .Clear
                .Add(0).Color = vbRed
                .Add(0.5).Color = vbRed
                .Add(0.5 + 0.001).Color = vbWhite
                .Add(1).Color = vbWhite
            End With
        End With
    End With

　　'縦に2分割
    With Cells(3, 1).Interior
        .Pattern = xlPatternLinearGradient
        With .Gradient
        .Degree = 90
            With .ColorStops
                .Clear
                .Add(0).Color = vbRed
                .Add(0.5).Color = vbRed
                .Add(0.5 + 0.001).Color = vbWhite
                .Add(1).Color = vbWhite
            End With
        End With
    End With

グラフの左上にしたいという人が多そうなのでこれが一番需要あるだろうか？

    '斜めに2分割(その2)
    With Cells(4, 1).Interior　'Cells(4,1)をSelectionに変えると選択しているセルが塗られる
        .Pattern = xlPatternLinearGradient
        With .Gradient
        .Degree = 135　'セルの縦横比によっては調整したほうがいいかも
            With .ColorStops
                .Clear
                .Add(0).Color = vbRed '右上半分の色　vb + (red/green/yellow/blue/black/whiteなど)または、ColorナンバーやRGBを指定する
                .Add(0.5).Color = vbRed　'右上半分の色
                .Add(0.5 + 0.001).Color = vbWhite　'左下半分の色
                .Add(1).Color = vbWhite　'左下半分の色
            End With
        End With
    End With

　　'3色縦分割
    With Cells(5, 1).Interior
        .Pattern = xlPatternLinearGradient
        With .Gradient
        .Degree = 0
            With .ColorStops
                .Clear
                .Add(0).Color = vbRed
                .Add(0.33).Color = vbRed
                .Add(0.331).Color = vbWhite
                .Add(0.66).Color = vbWhite
                .Add(0.661).Color = vbBlue
                .Add(1).Color = vbBlue
            End With
        End With
    End With
end Sub

塗りつぶしのグラデーションを使っているので正確には綺麗な分割ではありません
(0.5 と0.5001の間が赤から白のグラデーションになっていますが、見た目上は気にならないでしょう）

こちらは条件付き書式のデータバーの真似事

Sub B()
    Dim R, MIN, MAX As Long
    Dim TargetArea, Target As Range
    Dim P As Double
    For R = 1 To 10
        Cells(R, 2) = R
    Next R

    '範囲の設定
    Set TargetArea = Range("B1:B10")

    For Each Target In TargetArea
        'パーセンテージを求める
        P = Target / 10
　　　　'0％以上なら色を塗る
        If P > 0 Then
            With Target.Interior
                .Pattern = xlPatternLinearGradient
                With .Gradient
                .Degree = 0
                    With .ColorStops
                        .Clear
                        .Add(0).Color = vbGreen
                        .Add(P - 0.01).Color = vbGreen
                        .Add(P).Color = vbWhite
                        .Add(1).Color = vbWhite
                    End With
                End With
            End With
        End If
    Next Target
End Sub

Sub C()
    Dim R, MIN, MAX As Long
    Dim TargetArea, Target As Range
    Dim P As Double
    For R = 1 To 10
        Cells(R, 3) = Rnd() * 1000 Mod 100
    Next R

    '範囲の設定
    Set TargetArea = Range("C1:C10")
    '最大値と最小値を求める
    MAX = 100　'Worksheetfunction.MAX(targetArea) とかにすれば最大値を範囲内の最大に設定できる
    MIN = 0

    For Each Target In TargetArea
        'パーセンテージを求める
        P = (Target - MIN) / MAX
        If P > 0.001 Then
            With Target.Interior
                .Pattern = xlPatternLinearGradient
                With .Gradient
                .Degree = 0
                    With .ColorStops
                        .Clear
                        .Add(0).Color = vbYellow
                        .Add(P - 0.001).Color = vbYellow
                        .Add(P).Color = vbWhite
                        .Add(1).Color = vbWhite
                    End With
                End With
            End With
        End If
    Next Target
End Sub

応用としてこんなこともできるかと。
これはデータバーではできないこと

Sub DH()
    Dim R, C, MIN, MAX, targetColor As Long
    Dim TargetArea, Target As Range
    Dim P As Double
    Cells(1, 4) = "GOAL=100"
    Cells(2, 4) = "1st"
    Cells(2, 5) = "2nd"
    Cells(2, 6) = "3rd"
    Cells(2, 7) = "4th"
    Cells(2, 8) = "5th"
    Cells(2, 9) = "TOTAL"
    Cells(2, 10) = "AVE"
    Range("D3:Z13").Interior.Color = vbWhite '(追記)xlNoneからvbWhiteにすることで微妙な段差が発生しないようにしました
    Range("D3:Z13").ClearContents
    For R = 3 To 13
        For C = 4 To 5 + Int(Rnd() * 10 Mod 4)
            Cells(R, C) = Rnd() * 1000 Mod 30 + 10
        Next C
        Cells(R, 9) = WorksheetFunction.Sum(Range(Cells(R, 4), Cells(R, 9)))
        Cells(R, 10) = Round(WorksheetFunction.Average(Range(Cells(R, 4), Cells(R, 9))), 1)
        P = Cells(R, 9) / 100
        C = 4
        Do While P > 0.00001
            If C <= 8 Then
                targetColor = rgbLightSalmon
            ElseIf C <= 10 Then
                targetColor = rgbLime
            Else
                Exit Do
            End If

            If P < 0.2 And P > 0.00001 Then
                With Cells(R, C).Interior
                    .Pattern = xlPatternLinearGradient
                    With .Gradient
                    .Degree = 0
                        With .ColorStops
                            .Clear
                            .Add(0).Color = targetColor
                            .Add(P - 0.00001).Color = targetColor
                            .Add(P).Color = vbWhite
                            .Add(1).Color = vbWhite
                        End With
                    End With
                End With
                Exit Do
            Else
                Cells(R, C).Interior.Color = targetColor
                P = P - 0.2
                C = C + 1
            End If
        Loop
    Next R
End Sub

点検表

Sub LN()
    Dim LimitDay As Date
    Dim R, dayCount As Long
    Dim P As Double
    For R = 2 To 7
        '期限日を求める
        LimitDay = DateAdd("yyyy", Cells(R, 13), Cells(R, 14))
        '残り日数を求める
        dayCount = LimitDay - Now
        'パーセンテージの計算
        P = (Now - Cells(R, 14)) / (365 * 5)
        '残り日数に応じて色を塗る
        If P > 0.001 Then
            With Cells(R, 15).Interior
                .Pattern = xlPatternLinearGradient
                With .Gradient
                .Degree = 0
                    With .ColorStops
                        .Clear
                        .Add(0).color = vbBlue
                        .Add(P).color = vbBlue
                        .Add(P + 0.001).color = vbWhite
                        .Add(Cells(R, 13) / 5 - 0.01).color = vbWhite
                        .Add(Cells(R, 13) / 5).color = 15921906
                        .Add(1).color = 15921906
                    End With
                End With
            End With
        End If
    Next R
End Sub

グラフ(分布図)

Sub PV()
    Dim C As Long
     With Cells(3, 18).Interior
                .Pattern = xlPatternLinearGradient
                With .Gradient
                .Degree = 0
                    With .ColorStops
                        .Clear
                        .Add(0).color = vbWhite
                        For C = 17 To 23
                            .Add(Cells(2, C) / 100 - 0.005).color = vbWhite
                            .Add(Cells(2, C) / 100).color = color(C)
                            .Add(Cells(2, C) / 100 + 0.005).color = vbWhite
                            Cells(1, C).Interior.color = color(C)
                        Next C
                        .Add(1).color = vbWhite
                    End With
                End With
            End With
End Sub

Function color(i As Long) As Long
    Select Case i Mod 7
        Case Is = 0
            color = rgbLightBlue
        Case Is = 1
            color = vbRed
        Case Is = 2
            color = vbBlue
        Case Is = 3
            color = vbGreen
        Case Is = 4
            color = vbYellow
        Case Is = 5
            color = rgbOrange
        Case Is = 6
            color = rgbPink
        Case Else
            color = vbBlack
    End Select
End Function

このセル幅だと、線の幅は0.004以上なら見える。0.003だと薄い色が見えなくなってくる。
今回の場合は、１点差の幅が1/100＝0.01なのでこの設定。

線を太したければ

.Add(Cells(2, C) / 100 - 0.025).color = vbWhite
.Add(Cells(2, C) / 100).color = color(C)
.Add(Cells(2, C) / 100 + 0.025).color = vbWhite

とかにすれば太くなります。今回は0.05
近い数値が重なり合って細くなってしまいます（オレンジと緑）
同じ値だと幅をいくら細くしても表現できない
これ以上太いとグラデーションが目立ってくる。

For～Nextを２回使って、色を塗ると白に戻すをすれば近い数値もきれいに塗れるかもしれない。

誰かの参考になればうれしいです