|
楼主 |
发表于 2017-6-21 13:36
|
显示全部楼层
这个代码也不行,速度太慢了,
你喜欢录制宏?
给你两个代码好好学习
Sub 字典填充()
Dim d As Object
Dim arr As Variant
Dim i As Integer
Set d = CreateObject("scripting.dictionary")
ActiveSheet.[a1].CurrentRegion.Interior.ColorIndex = xlNone
arr = ActiveSheet.[a1].CurrentRegion
For i = 2 To UBound(arr)
If arr(i, 6) > 2000 Then
If Not d.exists(arr(i, 6)) Then
Set d(arr(i, 6)) = ActiveSheet.Range("a" & i).Resize(1, UBound(arr, 2))
Else
Set d(arr(i, 6)) = Union(d(arr(i, 6)), ActiveSheet.Range("a" & i).Resize(1, UBound(arr, 2)))
End If
End If
Next i
x = d.keys
For i = 0 To UBound(x)
d.items()(i).Interior.ColorIndex = 3
Next i
End Sub
’用数组填充颜色比字典要快些
Sub 数组填充()
Dim rng As Range
Dim arr As Variant
Dim i As Integer, t
t = Timer
ActiveSheet.[a1].CurrentRegion.Interior.ColorIndex = xlNone
arr = ActiveSheet.[a1].CurrentRegion
For i = 2 To UBound(arr)
If arr(i, 6) > 2000 Then
If rng Is Nothing Then
Set rng = ActiveSheet.Range("a" & i).Resize(1, UBound(arr, 2))
k = 1
Else
Set rng = Union(rng, ActiveSheet.Range("a" & i).Resize(1, UBound(arr, 2)))
k = k + 1
If k > 30 Then
rng.Interior.ColorIndex = 3
k = 0
Set rng = Nothing
End If
End If
End If
Next i
MsgBox Timer - t
End Sub
|
|