|
楼主 |
发表于 2014-4-22 14:01
|
显示全部楼层
VBA万岁 发表于 2014-4-22 13:47
方便把代码发过来吗?
我用的是2010,打开附件时,代码及VBE对象丢失。 供参考- Sub 筛选单元格颜色()
- On Error GoTo line
- Dim i As Long, ic%, myColor, Rng As Range, ir As Long '行变量,当前列号,当前颜色值,单元格选区
- Dim myRng As Range, j%, q As Long, qq%
- Dim d As Object, dic As Object
- Set d = CreateObject("scripting.dictionary")
- Set dic = CreateObject("scripting.dictionary")
- '--------------------------------------------------
- arr = Range(ActiveSheet.Range("a1"), ActiveSheet.Cells.SpecialCells(xlLastCell)) '把表中数据赋值给数值
- If IsArray(arr) = False Then MsgBox "当前表格中没有数据,或只有一个数据": Exit Sub
- ir = UBound(arr): Erase arr
- '--------------------------------------------------
- For Each Rng In Selection
- myColor = Rng.Interior.Color
- ic = Rng.Column
- d(ic & "|" & myColor) = 0
- dic(ic) = 0
- Next
- '--------------------------------------------------
- Application.ScreenUpdating = False '关闭屏闪'
- a = dic.keys: ic = dic.Count
- For i = 2 To ir
- qq = 0
- '--------------------------------------------------
- For j = 0 To ic - 1
- myColor = Cells(i, a(j)).Interior.Color
- If d.exists(a(j) & "|" & myColor) = True Then qq = qq + 1 Else Exit For
- Next j
- '--------------------------------------------------
- If qq = ic Then
- q = q + 1
- Else
- If myRng Is Nothing Then Set myRng = Rows(i) Else Set myRng = Union(myRng, Rows(i))
- End If
- Next i
- '--------------------------------------------------
- If q > 0 Then
- Application.ScreenUpdating = False
- Cells.AutoFilter ActiveCell.Column, "<>#@"
- myRng.RowHeight = 0
- ActiveWindow.ScrollRow = 1 '窗口跳转到第1行
- Application.ScreenUpdating = True
- End If
- line:
- Application.ScreenUpdating = True
- End Sub
复制代码
|
|