VBA - determine if two or more cells overlap in the same cell address

Question

I have a worksheet with filled colored cells within certain borders, and I have to "move" the filled cells randomly by an offset provided by NewX and NewY parameters, select the new cell, delete the filling of the "old" cell and fill the new cell with a different color.

The problems start after I perform a few runs - it seems that the cells "disappear" - less and less cells are seen with time, and I assume it's because some of them overlap each other and since my code is set to find filled cells only and move them, their number decreases with time.

This is the code I'm using to move the filled cells:

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

My concern is, the more times that you run the loop of i,j, more Cells(NewY, NewX).Select selections overlap, and thus determines less filled cells.

I was thinking about using the Cells.Address feature to determine beforehand if any cells overlap in their (NewY, NewX) position and avoid them to do so.

My other thought was to somehow split any cell that contains several addresses from other cells' offset to their original number, but I'm not that the Split feature is suitable for this situation. Is there any way to do that?

I'd appreciate your help.

Answer 1

I have to say that I think your phrasing in the question and comments has muddied our understanding of what you need.

As I see it, you want to select a single coloured cell and offset it randomly by up to 5 rows and 5 columns. You then want to fill the new cell red and the old cell clear. A restriction is that the new, randomly picked cell cannot be a red one. Is that right?

If so, then a way of managing the task is to create a range that only contains clear cells and randomly pick one cell from that range. To do this, you need to make use of the Union and Intersect functions. If you're not familiar with these, then you'll discover that quite a lot of care needs to be taken in checking for an 'uninstantiated' object (ie it is Nothing). In the code below, I've put a couple of helper functions that manage this checking for you.

The main routine, though, shows how you could handle this random selection and colour change. You'll need to add your own error handling should there be no red cells or unacceptable ranges:

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