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
CodePudding user response：
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 indexxlnoneand 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.Printlines in the Immediate window (Ctrl G).
Option Explicit
Sub GetColoredRegionAddressTEST()
Debug.Print GetColoredRegion(Range("M50000"))
End Sub
Function GetColoredRegionAddress(ByVal RandomCell As Range) As String
Application.FindFormat.Interior.ColorIndex = xlNone
With RandomCell.Cells(1)
If .Interior.ColorIndex = xlNone Then Exit Function
Dim ws As Worksheet: Set ws = .Worksheet
Dim cell As Range, fCell As Range, lCell As Range
' First Cell Row
With ws.Cells(1, .Column).Resize(.Row - 1)
Debug.Print .Address(0, 0)
Set cell = .Find(What:="", After:=.Cells(1), _
SearchDirection:=xlPrevious, SearchFormat:=True)
If cell Is Nothing Then Set fCell = .Cells _
Else Set fCell = cell.Offset(1)
End With
' First Cell (Column)
With ws.Cells(.Row, 1).Resize(, .Column - 1)
Debug.Print .Address(0, 0)
Set cell = .Find(What:="", After:=.Cells(1), _
SearchDirection:=xlPrevious, SearchFormat:=True)
If cell Is Nothing Then Set fCell = ws.Cells(fCell.Row, .Column) _
Else Set fCell = ws.Cells(fCell.Row, cell.Offset(, 1).Column)
End With
Debug.Print fCell.Address
' Last Cell Row
With .Resize(ws.Rows.Count - .Row).Offset(1)
Debug.Print .Address(0, 0)
Set cell = .Find(What:="", After:=.Cells(.Cells.Count), _
SearchFormat:=True)
If cell Is Nothing Then Set lCell = .Cells _
Else Set lCell = cell.Offset(-1)
End With
' Last Cell (Column)
With .Resize(, ws.Columns.Count - .Column).Offset(, 1)
Debug.Print .Address(0, 0)
Set cell = .Find(What:="", After:=.Cells(.Cells.Count), _
SearchFormat:=True)
If cell Is Nothing Then Set lCell = ws.Cells(lCell.Row, .Column) _
Else Set lCell = ws.Cells(lCell.Row, cell.Offset(, -1).Column)
End With
Debug.Print lCell.Address
GetColoredRegionAddress = ws.Range(fCell, lCell).Address
End With
End Function
CodePudding user response：
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
CodePudding user response：
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