请教单条件筛选结果去重和多条件筛选结果去重显示要怎么实现？

妖兽

请教老师们，

我想要实现将D列代码筛选为表1的A1单元格内容，且BU列筛选为否的情况下，将X列单号去重后显示在表1的A2开始往下。
还要实现仅将BU列筛选为否，将X列单号去重后显示在表2的A2开始往下。这两种筛选去重的代码要咋写？

感谢老师们相助~

peteryhr

可能是这样
Private Sub CommandButton1_Click()
Worksheets("表1").Range("A2:A10000").ClearContents

        Dim dict As Object, Arr, condition As String, i As Long
        Set dict = CreateObject("scripting.dictionary")
        condition = Worksheets("表1").Range("A1")
        With Worksheets("单号")
                Arr = .Range(.Range("D4"), .Cells(Rows.Count, "BU").End(xlUp))
                For i = 1 To UBound(Arr, 1)
                        If Arr(i, 1) = condition And Arr(i, UBound(Arr, 2)) = "否" Then
                                dict(Arr(i, 21)) = "'" & Arr(i, 21)
                        End If
                Next i
        End With
        Worksheets("表1").Range("A2").Resize(dict.Count, 1) = Application.Transpose(dict.items)

End Sub

ykcbf1100

一键查询，附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.7.18
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("单号")
   
5.         r = .Cells(Rows.Count, "d").End(3).Row
   
6.         Arr = .[a1].Resize(r, 73)
   
7.     End With
   
8.     ReDim brr(1 To r, 1 To 1)
   
9.     With Sheets("表1")
   
10.         st = CStr(.[a1].Value)
    
11.         .[a2:a10000] = ""
    
12.         For i = 4 To UBound(Arr)
    
13.             If CStr(Arr(i, 4)) = st Then
    
14.                 If Arr(i, 73) = "否" Then
    
15.                     s = CStr(Arr(i, 24))
    
16.                     If Not d.exists(s) Then
    
17.                         m = m + 1
    
18.                         d(s) = m
    
19.                         brr(m, 1) = s
    
20.                     End If
    
21.                 End If
    
22.             End If
    
23.         Next
    
24.         .Columns(1).NumberFormatLocal = "@"
    
25.         .[a2].Resize(m, 1) = brr
    
26.     End With
    
27.     ReDim brr(1 To UBound(Arr), 1 To 1)
    
28.     m = 0
    
29.     d.RemoveAll
    
30.     With Sheets("表2")
    
31.         .[a2:a10000] = ""
    
32.         For i = 4 To UBound(Arr)
    
33.             If Arr(i, 73) = "否" Then
    
34.                 s = CStr(Arr(i, 24))
    
35.                 If Not d.exists(s) Then
    
36.                     m = m + 1
    
37.                     d(s) = m
    
38.                     brr(m, 1) = s
    
39.                 End If
    
40.             End If
    
41.         Next
    
42.         .Columns(1).NumberFormatLocal = "@"
    
43.         .[a2].Resize(m, 1) = brr
    
44.     End With
    
45.     Set d = Nothing
    
46.     Application.ScreenUpdating = True
    
47.     MsgBox "OK！"
    
48. End Sub
    
49. 
    

复制代码

quqiyuan

你写的其实也差不多了，给你修改了下，仅供参考。。。

quqiyuan

代码如下。。。
Private Sub CommandButton1_Click()
    Worksheets("表1").Range("A2:A10000").ClearContents
    Worksheets("表2").Range("A2:A10000").ClearContents
    Dim dict As Object, Arr, condition As String, i As Long
    Set dict = CreateObject("scripting.dictionary")
    Set dict1 = CreateObject("scripting.dictionary")
    condition = Worksheets("表1").Range("A1")
    With Worksheets("单号")
            Arr = .Range(.Range("D4"), .Cells(Rows.Count, "bu").End(xlUp))
            For i = 1 To UBound(Arr, 1)
                    If Arr(i, 1) = condition And Arr(i, 70) = "否" Then
                        dict(Arr(i, 21)) = "'" & Arr(i, 21)
                    End If
                    If Arr(i, 70) = "否" Then
                        dict1(Arr(i, 21)) = "'" & Arr(i, 21)
                    End If
            Next i
    End With
    Worksheets("表1").Range("A2").Resize(dict.Count, 1) = Application.Transpose(dict.items)
    Worksheets("表2").Range("A2").Resize(dict1.Count, 1) = Application.Transpose(dict1.items)
    Set dict = Nothing
    Set dict1 = Nothing
    Beep
End Sub

妖兽

quqiyuan 发表于 2024-7-18 10:27
代码如下。。。
Private Sub CommandButton1_Click()
    Worksheets("表1").Range("A2:A10000").ClearCo ...

感谢感谢 非常好用 我研究研究这个码，原来是这么串一起的

妖兽

ykcbf1100 发表于 2024-7-18 10:24
参与一下。。。

感谢大神是想要的效果