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

我不得不说，我认为你在问题和评论中的措辞使我们对你需要的理解变得混乱。

在我看来，你想要选择一个单色的单元格并随机偏移最多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

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

1 个答案: