条件に基づきセルの背景色を塗りつぶす、またはクリアする

Sub prcFillOrClearGreyIfConditionMet()
    ' 条件に基づきセルの背景色を塗りつぶす、またはクリアする

    Const strRangeAddress As String = "F2:NG102" ' アドレスの範囲
    Const lngFillColor As Long = 15921906 ' 塗りつぶす色(薄いグレー色)

    Dim rngCell As Range ' 処理対象のセル
    Dim rngColumn7 As Range ' 各列の7行目のセル
    Dim ws As Worksheet
    Dim iCol As Integer ' 列インデックス

    Set ws = ThisWorkbook.Sheets("Sheet1")

    ' F列からNG列までループ
    For iCol = 6 To ws.Range(strRangeAddress).Columns(ws.Range(strRangeAddress).Columns.Count).Column
        Set rngColumn7 = ws.Cells(7, iCol)

        ' 指定範囲の各列の2行目から102行目までループ
        For Each rngCell In ws.Range(ws.Cells(2, iCol), ws.Cells(102, iCol))
            ' セルが結合されている、または値が入力されている場合はスキップ
            If rngCell.MergeCells Or Not IsEmpty(rngCell.Value) Then Continue For

            If rngColumn7.Value <> "" Then
                ' 7行目に文字が入力されている場合、色を塗りつぶす
                rngCell.Interior.Color = lngFillColor
            ElseIf rngCell.Interior.Color = lngFillColor Then
                ' 7行目が空白で、セルが既に薄いグレー色の場合、色をクリア
                rngCell.Interior.ColorIndex = xlNone
            End If
        Next rngCell
    Next iCol
End Sub

コメント