我撰寫了這段代碼來查找帶有背景顏色的平方范圍。
我的問題是在 36000 行 x 8 列的大范圍內執行需要 4 或 5 秒。
您有改進和加快下面參考的代碼的建議嗎？
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
uj5u.com熱心網友回復：
彩色矩形的范圍地址
- 對于給定的單元格，如果它的顏色索引不同于
xlNone，它將在所有四個方向上搜索以找到具有顏色索引的單元格，xlnone并使用下一個單元格（頂部或左側）或前一個單元格（底部或右側）回傳彩色矩形的地址。 - 假設給定的彩色單元格周圍有一個彩色矩形。
- 為了更好地理解它，請選擇一個范圍并將其涂成紅色。然后對該范圍內的任何單元格使用該函式并查看結果。
Debug.Print在即時視窗 ( Ctrl G)中查看函式行的子結果。
Option Explicit
Sub GetColoredRegionAddressTEST()
Debug.Print GetColoredRegionAddress(Range("M25000"))
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(1) _
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(.Cells.Count) _
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, .Cells(.Cells.Count).Column)
Else
Set lCell = ws.Cells(lCell.Row, cell.Offset(, -1).Column)
End If
End With
Debug.Print lCell.Address
GetColoredRegionAddress = ws.Range(fCell, lCell).Address
End With
End Function
uj5u.com熱心網友回復：
閱讀：優化 VBA 代碼以提高性能。關閉Application.ScreenUpdating和設定Application.Calculation將大大提高他的速度。
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
uj5u.com熱心網友回復：
你沒有提到是否可能有超過一個正方形的彩色單元格。假設存在，并且傳遞給您的函式的單元格在您想要的彩色正方形范圍內，那么您可能會發現 FindFormat 函式更快。訣竅是找到正方形的清晰單元格限制。
代碼看起來像這樣：
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
轉載請註明出處，本文鏈接：https://www.uj5u.com/yidong/437780.html