Excel 循环通过颜色填充的单元格，直到空白

我正在尝试创建一个Excel文档，其中填充了单元格（相关单元格的数量不同，一些单元格只有1个，其他10+个，列的数量相同）

我想选择“活动单元格区域”。例如，如果活动单元格为A11，则选择从A11一直到E14的填充区域（所有蓝色单元格）

这就是我目前得到的，我想我需要一个while循环，但我无法让它工作：

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Target.Worksheet.Range("N5:N1000")) Is Nothing Then
        If Cells(Target.Row, 1).Interior.ColorIndex <> xlNone Then
            If Cells(Target.Row, 14) = "x" Or Cells(Target.Row, 14) = "X" Then
                         Range("A" & ActiveCell.Row).Select

            End If
        End If
   End If

End Sub

Private子工作表\u更改（ByVal目标作为范围）
如果不相交（Target、Target.Worksheet.Range（“N5:N1000”））则为零
如果单元格（Target.Row，1）.Interior.ColorIndex xlNone，则
如果单元格（Target.Row，14）=“x”或单元格（Target.Row，14）=“x”，则
范围（“A”&ActiveCell.Row）。选择
如果结束
如果结束
如果结束
端接头

Excel工作表：

第一步：

第二步：

第三步：

---

如果要扩展单个单元格范围以覆盖相同填充的矩形范围，可以执行以下操作：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range

    Set c = Application.Intersect(Target.Cells(1), Me.Range("N5:N1000"))

    If Not c Is Nothing Then
        If Me.Cells(c.Row, 1).Interior.ColorIndex <> xlNone And _
                        UCase(Me.Cells(Target.Row, 14)) = "X" Then

            GetColorBlock(Me.Cells(c.Row, 1)).Select

        End If
    End If

End Sub

'Expand a single cell range to all neighboring cells with the same fill color
'  (assumes colored range is rectangular)  
Function GetColorBlock(c As Range) As Range
    Dim tl As Range, br As Range, clr As Long
    clr = c.Interior.Color
    Set tl = c
    Set br = c
    Do While tl.Row > 1
        If tl.Offset(-1, 0).Interior.Color <> clr Then Exit Do
        Set tl = tl.Offset(-1, 0)
    Loop
    Do While tl.Column > 1
        If tl.Offset(0, -1).Interior.Color <> clr Then Exit Do
        Set tl = tl.Offset(0, -1)
    Loop
    Do While br.Row < Rows.Count
        If br.Offset(1, 0).Interior.Color <> clr Then Exit Do
        Set br = br.Offset(1, 0)
    Loop
    Do While br.Column < Columns.Count
        If br.Offset(0, 1).Interior.Color <> clr Then Exit Do
        Set br = br.Offset(0, 1)
    Loop
    Set GetColorBlock = c.Worksheet.Range(tl, br)
End Function

Private子工作表\u更改（ByVal目标作为范围）
调光范围
Set c=Application.Intersect（目标.Cells（1），Me.Range（“N5:N1000”））
如果不是，那么c什么都不是
如果是Me.Cells（c.Row，1）。Interior.ColorIndex xlNone和_
UCase（Me.Cells（Target.Row，14））=“X”然后
GetColorBlock（Me.Cells（c.Row，1））。选择
如果结束
如果结束
端接头
'将单个单元格范围扩展到具有相同填充颜色的所有相邻单元格
'（假定颜色范围为矩形）
函数GetColorBlock（c作为范围）作为范围
变暗tl为范围，br为范围，clr为长度
clr=c.Interior.Color
设置tl=c
设置br=c
当tl.行>1时执行此操作
如果tl.Offset（-1，0）。Interior.Color clr，则退出Do
设置tl=tl.Offset（-1,0）
环
当tl.列>1时执行此操作
如果tl.Offset（0，-1）.Interior.Color clr，则退出Do
设置tl=tl.Offset（0，-1）
环
边做边br.Row

如果要扩展单个单元格范围以覆盖相同填充的矩形范围，可以执行以下操作：

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range

    Set c = Application.Intersect(Target.Cells(1), Me.Range("N5:N1000"))

    If Not c Is Nothing Then
        If Me.Cells(c.Row, 1).Interior.ColorIndex <> xlNone And _
                        UCase(Me.Cells(Target.Row, 14)) = "X" Then

            GetColorBlock(Me.Cells(c.Row, 1)).Select

        End If
    End If

End Sub

'Expand a single cell range to all neighboring cells with the same fill color
'  (assumes colored range is rectangular)  
Function GetColorBlock(c As Range) As Range
    Dim tl As Range, br As Range, clr As Long
    clr = c.Interior.Color
    Set tl = c
    Set br = c
    Do While tl.Row > 1
        If tl.Offset(-1, 0).Interior.Color <> clr Then Exit Do
        Set tl = tl.Offset(-1, 0)
    Loop
    Do While tl.Column > 1
        If tl.Offset(0, -1).Interior.Color <> clr Then Exit Do
        Set tl = tl.Offset(0, -1)
    Loop
    Do While br.Row < Rows.Count
        If br.Offset(1, 0).Interior.Color <> clr Then Exit Do
        Set br = br.Offset(1, 0)
    Loop
    Do While br.Column < Columns.Count
        If br.Offset(0, 1).Interior.Color <> clr Then Exit Do
        Set br = br.Offset(0, 1)
    Loop
    Set GetColorBlock = c.Worksheet.Range(tl, br)
End Function

Private子工作表\u更改（ByVal目标作为范围）
调光范围
Set c=Application.Intersect（目标.Cells（1），Me.Range（“N5:N1000”））
如果不是，那么c什么都不是
如果Me.Cells（c.Row，1）.Interior.ColorIndex xlNone和_
UCase（Me.Cells（Target.Row，14））=“X”然后
GetColorBlock（Me.Cells（c.Row，1））。选择
如果结束
如果结束
端接头
'将单个单元格范围扩展到具有相同填充颜色的所有相邻单元格
'（假定颜色范围为矩形）
函数GetColorBlock（c作为范围）作为范围
变暗tl为范围，br为范围，clr为长度
clr=c.Interior.Color
设置tl=c
设置br=c
当tl.行>1时执行此操作
如果tl.Offset（-1，0）.Interior.Color clr，则退出Do
设置tl=tl.Offset（-1,0）
环
当tl.列>1时执行此操作
如果tl.Offset（0，-1）.Interior.Color clr，则退出Do
设置tl=tl.Offset（0，-1）
环
边做边br.Row

不清楚“x”在这里扮演什么角色。。。此外，您的代码看起来也像事件处理程序中的代码-是吗？当用户在第14列中创建一个x作为蓝色的x时，我想选择所有相互接触的“填充”单元格，并将它们剪切到另一页。您应该添加一些屏幕截图，真的！第1步第2步第3步我真的需要一种方法来选择区域不清楚“x”在这里扮演什么角色。。。此外，您的代码看起来也像事件处理程序中的代码-是吗？当用户在第14列中创建一个x作为蓝色的x时，我想选择所有相互接触的“填充”单元格，并将它们剪切到另一页。您应该添加一些屏幕截图，真的！第1步第2步第3步我真的需要一种方法来选择区域Hi Tim，我所做的是将你的函数添加到我的代码中，但我无法让我工作<代码>私有子工作表\u如果不相交（Target，Target.Worksheet.Range（“N5:N1000”））则更改（ByVal目标作为范围），如果单元格（Target.Row，1）.Interior.ColorIndex xlNone则如果单元格（Target.Row，14）=“x”或单元格（Target.Row，14）=“x”，则更改范围（“A”&ActiveCell.Row）。在测试时选择“GetColorBlock End If End If End If End If End If End Sub，此代码有行/列边界问题-我将稍后尝试修复…修复了我的原始代码-现在应该做一些接近您需要的事情。Thx，Tim。作为IntedeHi Tim工作，我所做的是将你的函数添加到我的代码中，但我无法让我工作<代码>私有子工作表\u如果不相交（Target，Target.Worksheet.Range（“N5:N1000”））则更改（ByVal目标作为范围），如果单元格（Target.Row，1）.Interior.ColorIndex xlNone则如果单元格（Target.Row，14）=“x”或单元格（Target.Row，14）=“x”，则更改范围（“A”&ActiveCell.Row）。在测试时选择“GetColorBlock End If End If End If End If End If End Sub，此代码有行/列边界问题-我将稍后尝试修复…修复了我的原始代码-现在应该做一些接近您需要的事情。Thx，Tim。作为受贿者工作