循环范围，但排除一些单元格

Question

我写了下面有效的代码。

我想修改这个

Set rng = Application.Intersect(Target, Me.Range("M30:AM53"))
If Not rng Is Nothing Then 'only loop though any cells in M30:AM53

不是整个范围（M30：AM53）而是特定范围。
水平M31：O33，Q31：S33，...总共重复7次。
垂直，M31:O33, M35:O37,...重复 6 次。

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim trlRed As Long, oPhoneBlue As Long, adrGreen As Long, iosGrey As Long, cmnPurple As Long
    Dim rng As Range, cell As Range

    trlRed = RGB(230, 37, 30)
    oPhoneBlue = RGB(126, 199, 216)
    adrGreen = RGB(61, 220, 132)
    iosGrey = RGB(162, 170, 173)
    cmnPurple = RGB(165, 154, 202)

    'firstLvValFor = Array("TRIAL", "BEGINNER", "NOVICE", "INTERMEDIATE", "ADVANCED")
    secondLvValFor = Array("aaa", "bbb", "ccc", "ddd")

    thirdLvValFor_01 = Array("Basic", "Text", "PhoneCall", "mail", "camera")
    thirLvValFor_02 = Array("Security", "WhatsApp", "Wi-Fi")
    
    Set rng = Application.Intersect(Target, Me.Range("M30:AM53"))
    If Not rng Is Nothing Then 'only loop though any cells in M30:AM53
        For Each cell In rng.Cells
            If cell.Value = "Session" And cell.Offset(0, -2).Value = "TRIAL" Then
                cell.Offset(0, -2).Resize(1, 3).Interior.Color = trlRed

            ElseIf IsError(Application.Match(cell.Value, thirdLvValFor_01, 0)) = False And cell.Offset(0, -1).Value = "aaa" And cell.Offset(0, -2).Value <> "TRIAL" Then
                cell.Offset(0, -2).Resize(1, 3).Interior.Color = oPhoneBlue

            ElseIf cell.Value = "aaa" And IsError(Application.Match(cell.Offset(0, 1).Value, thirdLvValFor_01, 0)) = False And cell.Offset(0, -1).Value <> "TRIAL" Then
                cell.Offset(0, -1).Resize(1, 3).Interior.Color = oPhoneBlue

            ElseIf IsError(Application.Match(cell.Value, thirdLvValFor_01, 0)) = False And cell.Offset(0, -1).Value = "bbb" And cell.Offset(0, -2).Value <> "TRIAL" Then
                cell.Offset(0, -2).Resize(1, 3).Interior.Color = adrGreen

            ElseIf cell.Value = "bbb" And IsError(Application.Match(cell.Offset(0, 1).Value, thirdLvValFor_01, 0)) = False And cell.Offset(0, -1).Value <> "TRIAL" Then
                cell.Offset(0, -1).Resize(1, 3).Interior.Color = adrGreen ' I mistook following code cell.offset(0, 1) = value, this was wrong. The correct form is offset(0, 1).value. This works perfectly. 01/23/23 14:08

            ElseIf IsError(Application.Match(cell.Value, thirdLvValFor_01, 0)) = False And cell.Offset(0, -1).Value = "ccc" And cell.Offset(0, -2).Value <> "TRIAL" Then
                cell.Offset(0, -2).Resize(1, 3).Interior.Color = iosGrey

            ElseIf cell.Value = "ccc" And IsError(Application.Match(cell.Offset(0, 1).Value, thirdLvValFor_01, 0)) = False And cell.Offset(0, -1).Value <> "TRIAL" Then
                cell.Offset(0, -1).Resize(1, 3).Interior.Color = iosGrey

            ElseIf IsError(Application.Match(cell.Value, thirLvValFor_02, 0)) = False And cell.Offset(0, -1).Value = "ddd" And cell.Offset(0, -2).Value <> "TRIAL" Then
                cell.Offset(0, -2).Resize(1, 3).Interior.Color = cmnPurple

            ElseIf cell.Value = "ddd" And IsError(Application.Match(cell.Offset(0, 1).Value, thirLvValFor_02, 0)) = False And cell.Offset(0, -1).Value <> "TRIAL" Then
                cell.Offset(0, -1).Resize(1, 3).Interior.Color = cmnPurple

            Else
                cell.Interior.ColorIndex = xlColorIndexNone
            End If
        Next cell
    End If
End Sub

要在代码运行时锁定某些单元格，我必须更精确地修改范围。
在范围（M30：AM53）内，我想定期将函数应用于非相邻单元格（范围）。
在这种情况下，应排除上方 1 个单元格、下方 1 个单元格、右侧 1 个单元格。

Answer 1

以下函数从范围中删除某些单元格，但保留范围的其余部分。

Function ExceptRange(Rng As Range, Except As Range) As Range
Dim a As Long, Confirmed() As Range
For a = 1 To Rng.Cells.Count
    If Intersect(Rng.Cells(a), Except) Is Nothing Then
        If ExceptRange Is Nothing Then
            Set ExceptRange = Rng.Cells(a)
        Else
            Set ExceptRange = Union(ExceptRange, Rng.Cells(a))
        End If
    End If
Next
End Function

如果您在子程序中调用此方法，您可以在循环之前从

rng

中删除不需要的单元格，因此

For Each cell in Rng

会自动跳过您已删除的单元格。