请帮忙实现筛选功能

吉仔

表格筛选不能实现，可否帮忙解决问题，谢谢！

ykcbf1100

只做了全部公司的数据提取，因为你这个表选择单个公司时无法正常显示。

个人建议你把单个公司的选择放到一个单元格中去比较好。
现在的代码加个条件判断也适合单个公司的数据提取。

ykcbf1100

      因为审核，多发一次。现在删除。               

opel-wong

简单凑了一个，代码如下，供参考：


模块中：





工作表事件：

liulang0808

Private Sub Worksheet_Change(ByVal Target As Range)
    Set d = CreateObject("scripting.dictionary")
    r = Sheets("数据采集").Cells(Rows.Count, 2).End(3).Row
    arr = Sheets("数据采集").[a3].Resize(r - 2, Sheets("数据采集").UsedRange.Columns.Count)
    If Len(Target) = 0 Then Exit Sub
    If Target.CountLarge <> 1 Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    If Target.Address(0, 0) = "B1" Or Target.Address(0, 0) = "D1" Then
        x = 3 * (Val([d1]) + 1)
        If [b1] = "全部" Then
            y = 6
            For j = x To x + 2
                For i = 1 To UBound(arr)
                    arr(i, y) = arr(i, j)
                Next i
                y = y + 1
            Next j
            ActiveSheet.UsedRange.Offset(2).ClearContents
            [a3].Resize(UBound(arr), 8) = arr
        Else
            r = 0
            For j = 1 To UBound(arr)
                If arr(j, 2) = [b1] Then
                    r = r + 1
                    y = 6
                    For i = 1 To 5
                        arr(r, i) = arr(j, i)
                    Next i
                    For i = x To x + 2
                        arr(r, y) = arr(j, i)
                        y = y + 1
                    Next
                End If
            Next j
            ActiveSheet.UsedRange.Offset(2).ClearContents
            [a3].Resize(r, 8) = arr
        End If
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Set d = CreateObject("scripting.dictionary")
    arr = Sheets("数据采集").UsedRange
    If Target.Address(0, 0) = "B1" Then
        d("全部") = ""
        For j = 3 To UBound(arr)
            If Len(arr(j, 2)) > 0 Then
                d(arr(j, 2)) = ""
            End If
        Next j
        Call ttt([b1], d)
    Else
       If Target.Address(0, 0) = "D1" Then
            For j = 6 To UBound(arr, 2)
                If Len(arr(1, j)) > 0 Then
                    d(arr(1, j)) = ""
                End If
            Next j
            Call ttt([d1], d)
        End If
    End If
End Sub

Sub ttt(rng, d)
    With rng.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=Join(d.keys, ",")
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .IMEMode = xlIMEModeNoControl
        .ShowInput = True
        .ShowError = True
    End With
End Sub

opel-wong

搞了一个类模块自动判断的，供参考：



附件： 类模块实现多OptionButton点击事件.zip (33.13 KB, 下载次数: 16)

2023-2-3 16:16 上传

点击文件名下载附件

.

liulang0808

使用了两个表格事件，第一行做了做了调整

吉仔

谢谢楼上各位的帮忙

剑指E

tmplinshi