'Find Range Based on Interior.ColorIndex - Improve Performance

I've written this code to find squared Range spoted with a back ground color.

My problem is that it thakes 4 or 5 seconds to execute on a large range of 36000 row x 8 columns.

Do you have suggestions to improve and speed the code quoted below ?

Function RegionColoree(cel As Range)

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

End Function

excel vba

Solution 1:^[1]

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

Solution 2:^[2]

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

Sources

This article follows the attribution requirements of Stack Overflow and is licensed under CC BY-SA 3.0.

Source: Stack Overflow

Solution	Source
Solution 1	Ambie
Solution 2	TinMan

'Find Range Based on Interior.ColorIndex - Improve Performance

Solution 1:[1]

Solution 2:[2]

Sources

Related Questions

Solution 1:^[1]

Solution 2:^[2]