更快的代码找到彩色单元格(内部)，或加速' For each '循环

Question

我使用下面的代码选择彩色单元格(内部)在userange上排除第一行。
它可以工作，但是在大范围(例如20k)时速度很慢。
是否有更快的方法或加速For each环?
提前感谢你所有的帮助。

Application.ScreenUpdating = False

Dim ws As Worksheet: Set ws = ActiveSheet

Dim crg As Range      'UsedRange exclude First Row
Set crg = ws.UsedRange
Set crg = crg.Offset(1, 0).Resize(crg.Rows.Count - 1, crg.Columns.Count)

Dim mystr, cel As Range, FinalRange As Range
mystr = ""
For Each cel In crg
If cel.Interior.ColorIndex <> -4142 Then
mystr = mystr & cel.Address & ","
End If
Next
If mystr = "" Then
MsgBox "No colored cell found"
Else
Set FinalRange = ws.Range(Left(mystr, Len(mystr) - Len(",")))
End If

Application.ScreenUpdating = True

Answer 1

是，您可以考虑彩色单元格只有一种颜色黄色

也许这种代码更快?

Sub test()  
Set crg = ws.UsedRange
Set crg = crg.Offset(1, 0).Resize(crg.Rows.Count - 1, crg.Columns.Count)
With Application.FindFormat
.Clear
.Interior.Color = vbYellow
.Locked = True
End With
Dim rg As Range
Set c = crg.Find(What:=vbNullString, SearchFormat:=True)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
If rg Is Nothing Then Set rg = c Else Set rg = Union(rg, c)
Set c = crg.Find(What:=vbNullString, after:=c, SearchFormat:=True)
Loop While c.Address <> FirstAddress
rg.Select
Else
MsgBox "no cell with yellow color found"
End If
End Sub

最终结果将选择所有黄色的单元格或显示一个消息框
因此，它不会循环到crg中的每个单元格并检查循环的单元格颜色是否为黄色，而是直接在crg中找到具有黄色的单元格，然后将c作为rg变量，找到下一个黄色的单元格，然后将rg与c合并。