つらつら Excel VBA

私の備忘録です。

背景色の線グラデーションテスト

Excel VBA

きれいなグラデーションを作るにはセンスが必要！私には無理。

テスト結果
f:id:tanaka0:20220417163543p:plain

以下、テストコード

Sub 線グラデーションテスト()
    
    With ActiveSheet.Range("A1").Interior
        .Pattern = xlPatternLinearGradient
        .Gradient.Degree = 0
        With .Gradient.ColorStops
            .Clear
            .Add(0).Color = rgbWhite
            .Add(1).Color = rgbBlue
        End With
    End With
    
    With ActiveSheet.Range("B1").Interior
        .Pattern = xlPatternLinearGradient
        .Gradient.Degree = 180
        With .Gradient.ColorStops
            .Clear
            .Add(0).Color = rgbWhite
            .Add(1).Color = rgbBlue
        End With
    End With
    
    With ActiveSheet.Range("A3").Interior
        .Pattern = xlPatternLinearGradient
        .Gradient.Degree = 90
        With .Gradient.ColorStops
            .Clear
            .Add(0).Color = rgbWhite
            .Add(1).Color = rgbBlue
        End With
    End With
    
    With ActiveSheet.Range("B3").Interior
        .Pattern = xlPatternLinearGradient
        .Gradient.Degree = 630 '(270+360)。270で良い。
        With .Gradient.ColorStops
            .Clear
            .Add(0).Color = rgbWhite
            .Add(1).Color = rgbBlue
        End With
    End With
    
    '設定漏れテスト。Clearの有無でも変わる。
    With ActiveSheet.Range("A5").Interior
        .Pattern = xlPatternLinearGradient
        .Gradient.Degree = 10
        With .Gradient.ColorStops
            .Clear
            '.Add(0).Color = vbWhite
            .Add(0.4).Color = vbWhite
            .Add(0.8).Color = vbBlue
            '.Add(1).Color = vbBlue
        End With
    End With
    
    '等間隔に交互に設定
    With ActiveSheet.Range("A6").Interior
        .Pattern = xlPatternLinearGradient
        .Gradient.Degree = 0
        With .Gradient.ColorStops
            .Clear
            .Add(0).Color = RGB(255, 255, 255) '白
            .Add(0.2).Color = RGB(0, 0, 255) '青
            .Add(0.4).Color = RGB(255, 255, 255) '白
            .Add(0.6).Color = RGB(0, 0, 255) '青
            .Add(0.8).Color = RGB(255, 255, 255) '白
            .Add(1).Color = RGB(0, 0, 255) '青
        End With
    End With
    
    'ColorStopsの間隔を狭くするとグラデーションしていないように見える
    With ActiveSheet.Range("A7").Interior
        .Pattern = xlPatternLinearGradient
        .Gradient.Degree = 45
        With .Gradient.ColorStops
            .Clear
            .Add(0).Color = &HFFFFFF '白
            .Add(0.5).Color = &HFFFFFF '白 ここから
            .Add(0.51).Color = &HFF0000 '青 ここを狭くした
            .Add(1).Color = &HFF0000 '青
        End With
    End With
    
    'ColorStopsの数値を同じに。意図しない結果になる。
    With ActiveSheet.Range("A8").Interior
        .Pattern = xlPatternLinearGradient
        .Gradient.Degree = 45
        With .Gradient.ColorStops
            .Clear
            .Add(0).Color = &HFFFFFF '白
            .Add(0.5).Color = &HFFFFFF '白
            .Add(0.5).Color = &HFF0000 '青
            .Add(1).Color = &HFF0000 '青
        End With
    End With
    
    'ColorStopsの数値を同じにして色の順番を変えてみた。
    'これが正しい動きなのか分からず怖いのでやらない。
    With ActiveSheet.Range("A9").Interior
        .Pattern = xlPatternLinearGradient
        .Gradient.Degree = 45
        With .Gradient.ColorStops
            .Clear
            .Add(0).Color = &HFFFFFF '白
            .Add(0.5).Color = &HFF0000 '青 ここと
            .Add(0.5).Color = &HFFFFFF '白 ここを逆にした
            .Add(1).Color = &HFF0000 '青
        End With
    End With
    
    '虹1（赤, 橙, 黄, 緑, 青, 藍, 紫）
    With ActiveSheet.Range("A10").Interior
        .Pattern = xlPatternLinearGradient
        .Gradient.Degree = 5
        With .Gradient.ColorStops
            .Clear
            .Add(0).Color = rgbRed
            .Add(0.166).Color = rgbOrange
            .Add(0.333).Color = rgbYellow
            .Add(0.5).Color = rgbGreen
            .Add(0.666).Color = rgbBlue
            .Add(0.833).Color = rgbIndigo
            .Add(1).Color = rgbPurple
        End With
    End With
    
    '虹2（赤, 橙, 黄, 緑, 青, 藍, 紫）
    With ActiveSheet.Range("A11").Interior
        .Pattern = xlPatternLinearGradient
        .Gradient.Degree = 5
        With .Gradient.ColorStops
            .Clear
            .Add(0).Color = rgbRed
            .Add(0.142).Color = rgbRed
            .Add(0.143).Color = rgbOrange
            .Add(0.285).Color = rgbOrange
            .Add(0.286).Color = rgbYellow
            .Add(0.428).Color = rgbYellow
            .Add(0.429).Color = rgbGreen
            .Add(0.571).Color = rgbGreen
            .Add(0.572).Color = rgbBlue
            .Add(0.714).Color = rgbBlue
            .Add(0.715).Color = rgbIndigo
            .Add(0.857).Color = rgbIndigo
            .Add(0.858).Color = rgbPurple
            .Add(1).Color = rgbPurple
        End With
    End With
    
End Sub

'背景色、パターンをクリア。どちらも同結果。
Sub 背景色クリア()
    Cells.Interior.ColorIndex = xlNone
    Cells.Interior.Pattern = xlNone
End Sub


虹とか繰り返しの配色はコピペして使うことが考えられるので関数化してみた。
隣同士のセルでも違和感が無いよう同じ赤で囲むようにして、あれ？赤色だけ太くなるぞ、、、そりゃそうか。
角度をつけなければ違和感無いのでヨシ！

以下結果
f:id:tanaka0:20220417203012p:plain

以下（ｒｙ

Sub 関数化してみた()
    
    Dim myArray
    Dim r As range
    
    '虹背景
    myArray = Array(rgbRed, rgbOrange, rgbYellow, rgbGreen, rgbBlue, rgbIndigo, rgbPurple, rgbRed)
    Set r = Range("A13:E13")
    Call FillStripeColor2(r, 5, myArray)
    
    myArray = Array(rgbRed, rgbOrange, rgbYellow, rgbGreen, rgbBlue, rgbIndigo, rgbPurple)
    Set r = Range("A15:E15")
    Call FillStripeColor2(r, 0, myArray)
    
    'しまトラ模様（黄,黒,黄,黒,黄）
    myArray = Array(rgbYellow, rgbBlack, rgbYellow, rgbBlack, rgbYellow)
    Set r = Range("A17:E17")
    Call FillStripeColor2(r, 15, myArray)
    
End Sub

'背景を線グラデーションで装飾
'targetRange:対象セル範囲
'Angle:角度(0～360度)
'colorArray:色配列
Private Sub FillStripeColor2(targetRange As range, Angle As Integer, colorArray)
    
    Dim i As Long, setColor As Long
    Dim startSpan As Double
    Dim endSpan As Double
    
    Dim LineCount As Integer
    LineCount = UBound(colorArray) + 1
    
    '境目のぼかし具合調整。数が大きいほどぼける。
    '1 / LineCountより小さいこと。
    Dim blurBorder As Double
    blurBorder = (1 / LineCount) / 200
    
    With targetRange.Interior
        .Pattern = xlPatternLinearGradient '線グラデーション
        .Gradient.Degree = Angle '角度指定
        With .Gradient.ColorStops
            .Clear
            
            For i = LBound(colorArray) To UBound(colorArray)
                
                setColor = colorArray(i)
                
                '開始～終了の範囲計算
                Select Case i
                Case LBound(colorArray)
                    startSpan = 0
                    endSpan = 1 / LineCount
                Case UBound(colorArray)
                    startSpan = endSpan + blurBorder
                    endSpan = 1
                Case Else
                    startSpan = endSpan + blurBorder
                    endSpan = (1 / LineCount) * (i + 1)
                End Select
                
                '設定
                .Add(startSpan).Color = setColor
                .Add(endSpan).Color = setColor
                
                'デバッグ用
                'Debug.Print i & ", " & startSpan & "～" & endSpan & ", 色=" & setColor
                
            Next
            
        End With
    End With
End Sub

以上。