小白求助一个查重筛选的按钮，求大神帮助！

freetimefuns

上次好像传错了 这个满足 任意两列筛选

leaona

Qs18 发表于 2024-9-16 11:59
把附件改成你实际的工作表名字和行列的数据，重新发来看看

查重筛选.rar (9.91 KB, 下载次数: 4)

2024-9-16 14:18 上传

点击文件名下载附件

大概长这个样，麻烦您了！

Qs18

1. Sub qs()
   
2. Dim arr, i, rg As Range, rg2 As Range, dic As Object
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. With Sheet4
   
5.     x = Application.InputBox("请输入数字【 1 】按姓名筛选输入数字【 2 】按身份证号筛选")
   
6.     If x = 1 Then
   
7.     c = 3
   
8.     c2 = 30
   
9.     ElseIf x = 2 Then
   
10.     c = 4
    
11.     c2 = 31
    
12.     Else
    
13.     Exit Sub
    
14.     End If
    
15.     取消筛选
    
16.     RO = .Cells(Rows.Count, c).End(3).Row
    
17.     RO2 = .Cells(Rows.Count, c2).End(3).Row
    
18.     arr = .Range(.Cells(3, c), .Cells(RO, c))
    
19. Set rg = .Range(.Cells(3, c), .Cells(RO, c))
    
20. Set rg2 = .Range(.Cells(3, c2), .Cells(RO2, c2))
    
21. Set rg = Union(rg, rg2)
    
22. 
    
23. For Each r In rg
    
24.     If r.Value <> "" Then
    
25.         If Not dic.exists(r.Value) Then
    
26.             dic(r.Value) = 1
    
27.         Else
    
28.             dic(r.Value) = dic(r.Value) + 1
    
29.         End If
    
30.     End If
    
31. Next
    
32.     For i = 1 To UBound(arr)
    
33.         If dic(arr(i, 1)) = 1 Then
    
34.             .Rows(i + 2).Hidden = True
    
35.         End If
    
36.     Next
    
37. End With
    
38. Set dic = Nothing: Set rg = Nothing: Set rg2 = Nothing
    
39. End Sub
    
40. Sub 取消筛选()
    
41. Sheet4.Rows("1:200").Hidden = False
    
42. End Sub
    
43. 
    

复制代码

Qs18

请输入数字【 1 】按姓名筛选输入数字【 2 】按身份证号筛选

Qs18

请输入数字【 1 】按姓名筛选输入数字【 2 】按身份证号筛选

leaona

Qs18 发表于 2024-9-16 16:08
请输入数字【 1 】按姓名筛选输入数字【 2 】按身份证号筛选

我试试，先感谢！

leaona

Qs18 发表于 2024-9-16 16:08
请输入数字【 1 】按姓名筛选输入数字【 2 】按身份证号筛选

十分非常好用，谢谢您！
中秋快乐！！

leaona

freetimefuns 发表于 2024-9-16 13:48
上次好像传错了 这个满足 任意两列筛选

测试了，真的好用，任意两列，所有表格都能用，太神奇了，谢谢您！
中秋快乐啊！