Find Range Based on Interior.ColorIndex - Improve Performance

Range Address of a Colored Rectangle

• For a given cell, if its color index is different than xlNone, it will search in all four directions to find a cell with the color index xlnone and use the next cell (top or left) or the previous cell (bottom or right) to return the address of the colored rectangle.
• It is assumed that there is a colored rectangle around the given colored cell.
• To better understand it, select a range and color it in red. Then use the function with any cell inside the range and see the result.
• See the sub-results of the function's Debug.Print lines in the Immediate window (Ctrl+G).

Option Explicit

Sub GetColoredRegionAddressTEST()
    Debug.Print GetColoredRegionAddress(Range("G7"))
End Sub

Function GetColoredRegionAddress(ByVal RandomCell As Range) As String
    
    With RandomCell.Cells(1)

        If .Interior.ColorIndex = xlNone Then Exit Function

        With Application.FindFormat
           .Clear
           .Interior.ColorIndex = xlNone
        End With

        Dim ws As Worksheet: Set ws = .Worksheet
        Dim cell As Range, fCell As Range, lCell As Range
        Dim r As Long, c As Long, wCount As Long
        
        ' First Cell Row
        If .Row = 1 Then
            r = .Row
        Else
            With ws.Cells(1, .Column).Resize(.Row - 1)
                Debug.Print .Address(0, 0)
                Set cell = .Find(What:="", SearchDirection:=xlPrevious, _
                    SearchFormat:=True)
                If cell Is Nothing Then r = .Row Else r = cell.Row + 1
            End With
        End If
        
        ' First Cell Column
        If .Column = 1 Then
            c = .Column
        Else
            With ws.Cells(.Row, 1).Resize(, .Column - 1)
                Debug.Print .Address(0, 0)
                Set cell = .Find(What:="", SearchDirection:=xlPrevious, _
                    SearchFormat:=True)
                If cell Is Nothing Then c = .Column Else c = cell.Column + 1
            End With
        End If
        Set fCell = ws.Cells(r, c)
        Debug.Print fCell.Address
            
        ' Last Cell Row
        wCount = ws.Rows.Count
        If .Row = wCount Then
            r = wCount
        Else
            With .Resize(wCount - .Row).Offset(1)
                Debug.Print .Address(0, 0)
                Set cell = .Find(What:="", After:=.Cells(.Cells.Count), _
                    SearchFormat:=True)
                If cell Is Nothing Then r = wCount Else r = cell.Row - 1
            End With
        End If
        
        ' Last Cell Column
        wCount = ws.Columns.Count
        If .Column = wCount Then
            c = wCount
        Else
            With .Resize(, wCount - .Column).Offset(, 1)
                Debug.Print .Address(0, 0)
                Set cell = .Find(What:="", After:=.Cells(.Cells.Count), _
                    SearchFormat:=True)
                If cell Is Nothing Then c = wCount Else c = cell.Column - 1
            End With
        End If
        Set lCell = ws.Cells(r, c)
        Debug.Print lCell.Address
        
        GetColoredRegionAddress = ws.Range(fCell, lCell).Address

        Application.FindFormat.Clear
    
    End With

End Function

You don't mention whether there could be more than one square range of coloured cells. Assuming there is, and the cell passed into your function is within your desired coloured square range, then you might find the FindFormat function is quicker. The trick would be to find the clear cell limits of your square.

Code would look something like this:

Public Function ColouredCellRange(rng As Range) As Range
    Dim r(1) As Long, c(1) As Long
    
    On Error GoTo EH
    
    'Exit if cell isn't coloured.
    If rng.Interior.Color = xlNone Then Exit Function
    
    'Set the find format parameters.
    With Application.FindFormat
        .Clear
        .Interior.ColorIndex = xlNone
    End With

    'Find the left and right columns and top and bottom rows.
    With Sheet1.Cells
        c(0) = .Find(What:="", After:=rng, LookIn:=xlFormulas, LookAt:= _
            xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:= _
            False, SearchFormat:=True).Column
        r(0) = .Find(What:="", After:=rng, LookIn:=xlFormulas, LookAt:= _
            xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:= _
            False, SearchFormat:=True).Row
        c(1) = .Find(What:="", After:=rng, LookIn:=xlFormulas, LookAt:= _
            xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
            False, SearchFormat:=True).Column
        r(1) = .Find(What:="", After:=rng, LookIn:=xlFormulas, LookAt:= _
            xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
            False, SearchFormat:=True).Row
    End With
                
    With Sheet1
        'Test if square is on the edge of the sheet.
        If c(0) > rng.Column Then c(0) = 1 Else c(0) = c(0) + 1
        If r(0) > rng.Row Then r(0) = 1 Else r(0) = r(0) + 1
        If c(1) < rng.Column Then c(1) = .Columns.Count Else c(1) = c(1) - 1
        If r(1) < rng.Row Then r(1) = .Rows.Count Else r(1) = r(1) - 1
        
        'Return the square range.
        Set ColouredCellRange = .Range(.Cells(r(0), c(0)), .Cells(r(1), c(1)))
    End With
    Exit Function
EH:
End Function

Read: Optimize VBA Code for performance improvement. Turning off Application.ScreenUpdating and setting Application.Calculation will greatly improve he speed.

Function RegionColoree(cel As Range)
    Dim CalculationMode As XlCalculation
    
    Application.ScreenUpdating = False
    CalculationMode = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    i = 0
    ii = 0
    j = 0
    jj = 0

    Set cel = cel.Resize(1, 1)


    If Not cel.Interior.ColorIndex = xlNone Then

        Do While cel.Offset(i).Interior.ColorIndex <> xlNone 'vers le bas
            i = i + 1
        Loop
        Do While cel.Offset(ii).Interior.ColorIndex <> xlNone 'vers le haut
            ii = ii - 1
        Loop
        Do While cel.Offset(, j).Interior.ColorIndex <> xlNone 'vers la droite
            j = j + 1
        Loop
        Do While cel.Offset(, jj).Interior.ColorIndex <> xlNone 'vers la gauche
            jj = jj - 1
        Loop
    
        ii = ii + 1
        jj = jj + 1
    
        RegionColoree = cel.Offset(ii, jj).Resize(i - ii, j - jj).Address
    
    End If
    
    Application.Calculation = CalculationMode
End Function