VBA - 确定两个或多个单元格是否在同一单元格地址中重叠

Question

我有一个在某些边界内填充彩色单元格的工作表，我必须通过NewX 和NewY 参数提供的偏移量随机“移动”填充单元格，选择新单元格，删除填充“旧”单元格并用不同的颜色填充新单元格。

问题在我执行几次运行后开始 - 似乎细胞“消失” - 随着时间的推移，看到的细胞越来越少，我认为这是因为其中一些 重叠 彼此之间，由于我的代码设置为仅查找填充的单元格并移动它们，它们的数量随着时间的推移而减少。

这是我用来移动填充单元格的代码：

Sub Move_Cells()

 For k = 1 to 20 'number of runs to perform the determination and movement of cells

  For i = 1 To 20 'the number can change due to borders
   For j = 1 To 20 'the number can change due to borders
     If Cells(i, j).Interior.ColorIndex <> xlNone Then
       x = j
        Y = i
       Randomize
        dX = Int((5 - 1 + 1) * Rnd() + 1)
       Randomize
        dY = Int((5 - 1 + 1) * Rnd() + 1)

         NewX = x + dX
          NewY = Y + dY

           Cells(NewY, NewX).Select
             Cells(i, j).Interior.ColorIndex = 0

              Selection.Interior.Color = 3
 next k

End Sub

我担心的是，您运行 i,j 循环的次数越多，Cells(NewY, NewX).Select 选择重叠的次数越多，从而确定填充的单元格越少。

我正在考虑使用Cells.Address 功能预先确定是否有任何单元格在其(NewY, NewX) 位置重叠并避免它们这样做。

我的另一个想法是以某种方式将包含多个地址的任何单元格从其他单元格的偏移量拆分为其原始编号，但我并不是说Split 功能适合这种情况。有什么办法吗？

感谢您的帮助。

Answer 1

我不得不说，我认为您在问题和 cmets 中的措辞混淆了我们对您需要什么的理解。

如我所见，您希望选择单个彩色单元格并将其随机偏移最多 5 行和 5 列。然后，您要将新单元格填充为红色，并将旧单元格填充为透明。一个限制是，随机挑选的新单元格不能是红色单元格。对吗？

如果是这样，那么管理任务的一种方法是创建一个仅包含透明单元格的范围，并从该范围内随机选择一个单元格。为此，您需要使用Union 和Intersect 函数。如果您不熟悉这些，那么您会发现在检查“未实例化”对象（即Nothing）时需要非常小心。在下面的代码中，我放置了几个帮助函数来为您管理此检查。

不过，主程序展示了如何处理这种随机选择和颜色变化。如果没有红色单元格或不可接受的范围，您需要添加自己的错误处理：

Public Sub RunMe()
    Dim border As Range
    Dim cell As Range, newCell As Range
    Dim filled As Range, blanks As Range
    Dim n As Long, i As Long

    'Define range of matrix
    Set border = ThisWorkbook.Worksheets("Sheet1").Range("A1:T20")

    'Find the coloured cells
    For Each cell In border.Cells
        If cell.Interior.ColorIndex = 3 Then
            Set filled = Add(filled, cell)
        End If
    Next

    Randomize

    For i = 1 To 100
        'Generate a random index of the filled cells
        n = Int(filled.Count * Rnd + 1)
        Set cell = CellAt(filled, n)

        'Find the blank cells within 5 of the filled cell
        Set blanks = FindBlanks(border, filled, cell, 5)

        'Generate a random index of the blank cells
        n = Int(blanks.Count * Rnd + 1)
        Set newCell = CellAt(blanks, n)

        'Repaint the cells
        cell.Interior.ColorIndex = xlNone
        newCell.Interior.ColorIndex = 3

        'Swap cells
        Set filled = Remove(filled, cell)
        Set filled = Add(filled, newCell)

    Next
End Sub

Private Function FindBlanks(border As Range, _
                            filled As Range, _
                            target As Range, _
                            limit As Integer) As Range
    Dim topRow As Long
    Dim bottomRow As Long
    Dim leftCol As Long
    Dim rightCol As Long
    Dim rng As Range


    With border
        topRow = WorksheetFunction.Max(target.Row - 5, .Rows(1).Row)
        bottomRow = WorksheetFunction.Min(target.Row + 5, .Rows(.Rows.Count).Row)
        leftCol = WorksheetFunction.Max(target.Column - 5, .Columns(1).Column)
        rightCol = WorksheetFunction.Min(target.Column + 5, .Columns(.Columns.Count).Column)

        Set rng = .Range(.Cells(topRow, leftCol), .Cells(bottomRow, rightCol))
    End With

    Set FindBlanks = Remove(rng, filled)

End Function

Private Function CellAt(rng As Range, index As Long) As Range
    Dim cell As Range
    Dim i As Long

    If Not rng Is Nothing Then
        i = 1
        For Each cell In rng.Cells
            If i = index Then
                Set CellAt = cell
                Exit Function
            End If
            i = i + 1
        Next
    End If
End Function

Private Function Add(rng1 As Range, rng2 As Range) As Range
    If rng1 Is Nothing Then
        If Not rng2 Is Nothing Then
            Set Add = rng2
        End If
    Else
        If rng2 Is Nothing Then
            Set Add = rng1
        Else
            Set Add = Union(rng1, rng2)
        End If
    End If
End Function

Private Function Remove(rng1 As Range, rng2 As Range) As Range
    Dim cell As Range

    If Not rng1 Is Nothing Then
        If rng2 Is Nothing Then
            Set Remove = rng1
        Else
            For Each cell In rng1.Cells
                If Intersect(cell, rng2) Is Nothing Then
                    Set Remove = Add(Remove, cell)
                End If
            Next
        End If
    End If
End Function