EXCEL按单元格颜色进行筛选 VBA代码 FOR EXCEL2003 （原创）

原创代码：

 

1 自定义工具栏

Sub MeNu_自定义模块() On Error GoTo ERR Dim M(1) As String MeNa = "自定义的模块" M(1) = "颜色筛选列表" For Each Menu In CommandBars If Menu.Name = MeNa Then CommandBars(MeNa).Delete Next Set Menu = CommandBars.Add(Name:=MeNa, Position:=msoBarTop, Temporary:=True) Menu.Visible = True N = 1 Set Mn = Menu.Controls.Add(Type:=1) Mn.Caption = M(N) Mn.Visible = True Mn.OnAction = M(N) Mn.FaceId = 306 Mn.Style = 3 Exit Sub ERR: MsgBox Error$ End Sub

 

2 建立颜色筛选列表

Sub 颜色筛选列表() '--------------------------------------------------- '核心代码，可自行修改，修改后结果自行验证。 '作者姓名:wh Dept:财务管理会计 '做成日期:2011-06-22 '测试BUG联络:[email protected] '---------------------------------------------------- On Error GoTo ERR Dim i As Long Dim strCol As String Dim strTemp As String Dim Collect As New Collection Dim sig As Boolean sig = False For Each CB In Menu.Controls If CB.Type = msoControlComboBox Then Menu.Controls.Item(2).Delete End If Next CurrentCol = Selection.Column CurrentRow = Selection.Row If InStr(1, Selection.Address, ":") > 0 Then strTemp = Replace(Selection.Address, ":", "") If Split(strTemp, "$")(1) = Split(strTemp, "$")(2) Then strCol = Split(strTemp, "$")(1) & ":" & Split(strTemp, "$")(1) Else MsgBox "不支持多列选择" GoTo ERR End If Else strTemp = Selection.Address strCol = Split(strTemp, "$")(1) & ":" & Split(strTemp, "$")(1) End If For i = 1 To 255 If ActiveSheet.Cells(CurrentRow + 1, i).Value <> "" Then sig = True Exit For End If Next If CurrentCol <> 1 Then If ActiveSheet.Cells(CurrentRow, CurrentCol - 1).Value <> "" Then Startcol = ActiveSheet.Cells(CurrentRow, CurrentCol).End(xlToLeft).Column Else Startcol = ActiveSheet.Cells(CurrentRow, CurrentCol).Column End If Else Startcol = 1 End If If Not sig Then MsgBox "数据区域必须存在有效值" GoTo ERR End If Columns(strCol).Insert shift:=xlToRight Selection.NumberFormatLocal = "@" Selection.EntireColumn.Hidden = True InsertCol = Selection.Column CurrentCol = CurrentCol + 1 ActiveSheet.Cells(CurrentRow, InsertCol).Value = "筛选辅助列" ActiveSheet.Cells(CurrentRow, CurrentCol).Select Set CB = Menu.Controls.Add(Type:=msoControlComboBox) CB.OnAction = "FilterColor" On Error Resume Next For i = CurrentRow To 65535 If ActiveSheet.Cells(i, CurrentCol).Interior.ColorIndex <> xlNone Then Collect.Add ActiveSheet.Cells(i, CurrentCol).Interior.ColorIndex, Str(ActiveSheet.Cells(i, CurrentCol).Interior.ColorIndex) ActiveSheet.Cells(i, InsertCol).Value = Trim(Str(ActiveSheet.Cells(i, CurrentCol).Interior.ColorIndex)) End If Next Collect.Add "All color", "ALLCOLOR" Collect.Add "取消颜色筛选", "取消颜色筛选" On Error GoTo 0 For i = 1 To Collect.Count CB.AddItem Collect.Item(i) Next Exit Sub ERR: If Error$ <> "" Then MsgBox Error$ End If End Sub

 

3 筛选代码，combox的change方法调用

Sub FilterColor() '--------------------------------------------------- '核心代码，可自行修改，修改后结果自行验证。 '作者姓名:wh Dept:财务管理会计 '做成日期:2011-06-22 '测试BUG联络:[email protected] '---------------------------------------------------- Dim c As String c = CB.Text If c = "取消颜色筛选" Then If ActiveSheet.FilterMode Then Selection.AutoFilter CB.Text = "" Columns(InsertCol).Delete CB.Visible = False Else CB.Text = "" Columns(InsertCol).Delete CB.Visible = False End If Else If c = "All color" Then ActiveSheet.Cells(CurrentRow, InsertCol).Select Selection.AutoFilter Field:=(InsertCol - Startcol) + (Startcol - (Startcol - 1)), Criteria1:="<>" Else ActiveSheet.Cells(CurrentRow, InsertCol).Select Selection.AutoFilter Field:=(InsertCol - Startcol) + (Startcol - (Startcol - 1)), Criteria1:=c End If End If End Sub

 

4.在workbook_open里调用自定义模块，并且将文件存为加载宏，在EXCEL里加载后，随时可以使用了。

 

目前为止可以实现任何连续区域内的颜色筛选，其他变态需求就无视了。

 

网上有很多通过定义名称来实现筛选的，感觉不太好用，所以自己做了一个。