[Excel][VBA] セルの背景を半分ずつ塗りつぶす試み

0.README.md

[Excel][VBA] セルの背景を半分ずつ塗りつぶす試み

いき.xls［互換モード］ @aero_iki さんさんが興味深い試みをされていました。
へクスマップのようなシートで、セルをクリックするとその部分のへクスが塗りつぶされるというネタなのですが、このツイートを見ると、エクセルのセルの背景を斜めに区切って半分だけ塗りつぶしているように見えます。

面白そうだったので、似たようなことができないかを試してみました。

※動画はこちら

実は自分の方法はテレワーカーY @Artesia78 さんにより既出であり、しかも@aero_ikiさんの方法とも違っていたようなのですが、せっかくなのでソースコードをさらしておきます。

仕組みとしては、セルの背景塗りつぶし効果のグラデーションの機能を利用しています。
グラデーションは通常、指定した範囲をある色（色1）から別の色（色2）まで徐々に変化させていくものですが、色1と色2を同じにしてやるとその範囲を単一色で塗りつぶすこともできます。 これを利用して、範囲を2つ（「0～0.49…」「0.5～1」）作り、それぞれを白、黒で塗りつぶしてやれば、背景色が半分だけ黒くなったセルを作ることができます。

@aero_ikiさんの方法と比較すると

• セル単位で設定可能
• 値が入力されていない空のセルでも設定可能

というメリットがありますが、難点としては、

• 旧版のエクセルだと表示が崩れる（白黒の境がぼやけたりする）
• 通常の「セルの書式設定」操作では指定できないためにVBAで設定しておく必要がある（いったん指定してしまえばコピーや書式のコピーは有効）

あたりですかね。

おまけとして、へクスマップもどきのコードも併せてのせておきます。
※空のシートを作成してシートモジュールにコードを貼り付け、InitHexMap プロシージャを実行します。

※動画はこちら

Mod_FillHalf.vba

Option Explicit

Sub FillHalfColor(TargetCell, Color1, Color2, Angle)
    With TargetCell.Interior
        .Pattern = xlPatternLinearGradient
        .Gradient.Degree = Angle
        With .Gradient.ColorStops
            .Clear
            With .Add(0)
                .Color = Color1
                .TintAndShade = 0
            End With
            With .Add(0.499999999999999)
                .Color = Color1
                .TintAndShade = 0
            End With
            With .Add(0.5)
                .Color = Color2
                .TintAndShade = 0
            End With
            With .Add(1)
                .Color = Color2
                .TintAndShade = 0
            End With
        End With
    End With
End Sub

Sub TestFillHalf()
    Application.ScreenUpdating = False
    Dim BaseCell
    Set BaseCell = Range("A1")
    FillHalfColor BaseCell.Offset(0, 0), rgbWhite, rgbBlack, 45
    FillHalfColor BaseCell.Offset(0, 1), rgbWhite, rgbBlack, 135
    FillHalfColor BaseCell.Offset(1, 0), rgbWhite, rgbBlack, 315
    FillHalfColor BaseCell.Offset(1, 1), rgbWhite, rgbBlack, 225
    Application.ScreenUpdating = True
 End Sub

Sheet_Hexmap.vba

Option Explicit

Private Const HexMapRowCount = 50
Private Const HexMapColumnCount = 100

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    'If Target.Cells.CountLarge <> 1 Then Exit Sub
    Set Target = Target.Resize(1, 1) ' 選択セル範囲の左上のセルが対象
    If Intersect(Target, HexMapRange) Is Nothing Then Exit Sub
    Dim BaseCell As Range ' へクスの右下のセル
    Select Case CellKind(Target)
        ' CellKind
        ' ／￣￣＼＿＿
        ' 1 2 3 4 5 6
        Case 2
            Set BaseCell = Target.Offset(1, 2)
        Case 3
            Set BaseCell = Target.Offset(1, 1)
        Case 5
            Set BaseCell = Target.Offset(0, 2)
        Case 6
            Set BaseCell = Target.Offset(0, 1)
        Case Else
            ' 斜め罫線のセル（1または4）のときは無視
            Exit Sub
    End Select
    Dim FillFlag: FillFlag = (Target.Interior.Color = rgbWhite)
    Dim WorkCell, OffsetRow, OffsetColumn, CellPosition
    Application.ScreenUpdating = False
    CellPosition = 8 ' 1:へクスの左上～8:同右下
    ' CellPosition
    ' ／￣￣＼ : 1 2 3 4
    ' ＼＿＿／ : 5 6 7 8
    On Error Resume Next ' シート外の座標を指定した際のエラーを無視
    For OffsetRow = 0 To -1 Step -1
        For OffsetColumn = 0 To -3 Step -1
            ChangeCellColor BaseCell.Offset(OffsetRow, OffsetColumn), CellPosition, FillFlag
            CellPosition = CellPosition - 1
        Next
    Next
    Application.ScreenUpdating = True
End Sub

Sub InitHexMap()
    Application.ScreenUpdating = False
    Me.Cells.Delete
    Dim TargetRange As Range: Set TargetRange = HexMapRange()
    With TargetRange
        '.ClearFormats
        .RowHeight = 43
        .ColumnWidth = 3.38
    End With
    With TargetRange.Cells.Interior
        .Pattern = xlPatternNone
        .Color = rgbWhite
    End With
    Dim WorkCell As Range, CellBorder
    Dim CellValue
    For Each WorkCell In TargetRange.Cells
        Select Case CellKind(WorkCell)
            Case 1
                Set CellBorder = WorkCell.Borders(xlDiagonalUp)
            Case 2, 3
                Set CellBorder = WorkCell.Borders(xlEdgeTop)
            Case 4
                Set CellBorder = WorkCell.Borders(xlDiagonalDown)
            Case 5, 6
                Set CellBorder = WorkCell.Borders(xlEdgeBottom)
        End Select
        With CellBorder
            .LineStyle = xlContinuous
            .Color = rgbBlack
            .TintAndShade = 0
            .Weight = xlThin
        End With
    Next
    Application.Goto Me.Range("A1")
    Application.ScreenUpdating = True
End Sub

Sub ClearHexMap()
    Application.ScreenUpdating = False
    Dim TargetRange As Range: Set TargetRange = HexMapRange()
    With TargetRange.Cells.Interior
        .Pattern = xlPatternNone
        .Color = rgbWhite
    End With
    Application.Goto Me.Range("A1")
    Application.ScreenUpdating = True
End Sub

Private Property Get HexMapRange()
    Set HexMapRange = Me.Range("A1").Resize(HexMapRowCount, HexMapColumnCount)
End Property

Private Property Get CellKind(WorkCell As Range)
    ' CellKind
    ' ／￣￣＼＿＿
    ' 1 2 3 4 5 6
    CellKind = (WorkCell.Column + IIf(WorkCell.Row Mod 2, 0, 3) - 1) Mod 6 + 1
End Property

Private Sub ChangeCellColor(WorkCell As Range, CellPosition, FillFlag)
    If Intersect(WorkCell, HexMapRange) Is Nothing Then Exit Sub
    ' CellPosition
    ' ／￣￣＼ : 1 2 3 4
    ' ＼＿＿／ : 5 6 7 8
    With WorkCell.Interior
        Select Case CellPosition
            Case 2, 3, 6, 7
                .Pattern = xlPatternNone
                .Color = IIf(FillFlag, rgbBlack, rgbWhite)
            Case Else
                If .Pattern = xlPatternLinearGradient Then
                    .Color = IIf(FillFlag, rgbBlack, rgbWhite)
                Else
                    Select Case CellPosition
                        Case 1
                            FillHalfColor WorkCell, rgbWhite, rgbBlack, IIf(FillFlag, 45, 225)
                        Case 4
                            FillHalfColor WorkCell, rgbWhite, rgbBlack, IIf(FillFlag, 135, 315)
                        Case 5
                            FillHalfColor WorkCell, rgbWhite, rgbBlack, IIf(FillFlag, 315, 135)
                        Case 8
                            FillHalfColor WorkCell, rgbWhite, rgbBlack, IIf(FillFlag, 225, 45)
                    End Select
                End If
        End Select
    End With
End Sub

Private Sub FillHalfColor(TargetCell, Color1, Color2, Angle)
    With TargetCell.Interior
        .Pattern = xlPatternLinearGradient
        .Gradient.Degree = Angle
        With .Gradient.ColorStops
            .Clear
            With .Add(0)
                .Color = Color1
                .TintAndShade = 0
            End With
            With .Add(0.499999999999999)
                .Color = Color1
                .TintAndShade = 0
            End With
            With .Add(0.5)
                .Color = Color2
                .TintAndShade = 0
            End With
            With .Add(1)
                .Color = Color2
                .TintAndShade = 0
            End With
        End With
    End With
End Sub