用VBA数组或字典把F列一万行填充颜色

laoau128

用VBA数组或字典把F列一万行填充颜色

cflood

这个问题对于高级也太简单了

lsc900707

cflood 发表于 2017-6-21 08:50
这个问题对于高级也太简单了

他只能算问题高级，呵呵。。。。。。

cqlpjxx

’用数组填充颜色比字典要快些
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

AOZHIJUN1

Sub TEST()
Dim xrow As Integer, I As Long
xrow = ActiveSheet.UsedRange.Rows.Count
For I = 2 To xrow
   If Range("F" & I) > 2000 Then Range("A" & I, "F" & I).Interior.ColorIndex = 3
   Next
End Sub

laoau128

AOZHIJUN1 发表于 2017-6-21 11:41
Sub TEST()
Dim xrow As Integer, I As Long
xrow = ActiveSheet.UsedRange.Rows.Count

你这个最基本

laoau128

cqlpjxx 发表于 2017-6-21 10:32
’用数组填充颜色比字典要快些
Sub 数组填充()
Dim  rng As Range

你果然高手了

AVEL

1. Sub test()
   
2.     Application.ScreenUpdating = False
   
3.     With Sheet1
   
4.         .Range("a:f").Interior.ColorIndex = -4142
   
5.         .Range("A1:F10000").AutoFilter Field:=6, Criteria1:=">2000"
   
6.         .Range("a2:f10000").SpecialCells(xlCellTypeVisible).Interior.Color = vbRed
   
7.         .ShowAllData
   
8.     End With
   
9.     Application.ScreenUpdating = True
   
10. End Sub
    

复制代码