如何用VBA代码实现多重条件下的不重复值提取

天边2021

如图，如何用VBA代码实现多重条件下的不重复值提取，请大神指教

excel玉米

一般来讲，合并汇总用数组+字典就可以了

dragonthree

确实，最简单的数组+字典就可以了，一个FOR-NEXT，2个IF语名，字典就OK了

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.12.12
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("原料出入明细")
   
5.         r = .Cells(Rows.Count, 2).End(3).Row
   
6.         arr = .[a1].Resize(r, 7)
   
7.     End With
   
8.     With Sheets("B")
   
9.         rq = .[c3].Value
   
10.         xm = .[d3].Value
    
11.         For i = 8 To UBound(arr)
    
12.             If arr(i, 2) = rq Then
    
13.                 If arr(i, 4) = xm Then
    
14.                    s = arr(i, 7)
    
15.                    d(s) = ""
    
16.                 End If
    
17.             End If
    
18.         Next
    
19.         .[c5].Resize(10000) = ""
    
20.         .[c5].Resize(d.Count, 1) = Application.Transpose(d.keys)
    
21.     End With
    
22.     Set d = Nothing
    
23.     Application.ScreenUpdating = True
    
24.     MsgBox "OK！"
    
25. End Sub
    

复制代码

liulang0808

https://club.excelhome.net/threa ... tml?_dsign=b73ad3d6
求人不如求己，有些案例可以参考的

taller

1. Option Explicit
   
2. 
   
3. Sub SqlQuery()
   
4.     Dim conn As Object, rst As Object, strSQL$, i&, PathStr$, sht As Worksheet
   
5.     If VBA.IsDate([c3]) And Len([d3]) > 0 Then
   
6.         Set conn = CreateObject("ADODB.Connection")
   
7.         Set rst = CreateObject("ADODB.Recordset")
   
8.         PathStr = ThisWorkbook.FullName
   
9.         Set sht = Sheet2
   
10.         Dim rData As Range: Set rData = sht.Range("B7:G" & sht.Cells(sht.Rows.Count, 2).End(xlUp).Row)
    
11.         Select Case Application.Version * 1
    
12.             Case Is <= 11
    
13.                 conn.Open "Provider=Microsoft.Jet.Oledb.4.0;Data Source=" & PathStr & ";Extended Properties='Excel 8.0;HDR=Yes;IMEX=0'"
    
14.             Case Is >= 12
    
15.                 conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & PathStr & ";Extended Properties='Excel 12.0;HDR=Yes;IMEX=0'"
    
16.         End Select
    
17.         strSQL = "SELECT DISTINCT 品名 FROM [原料出入明细$" & rData.Address(0, 0) _
    
18.             & "] WHERE 日期=#" & [c3].Text & "# AND 出入类型='" & [d3] & "'"
    
19.         rst.Open strSQL, conn, 1, 1
    
20.         With Sheet3
    
21.             Dim lastR As Long: lastR = .Cells(.Rows.Count, 3).End(xlUp).Row
    
22.             If lastR > 5 Then .Range("C5:C" & lastR).ClearContents
    
23.             .Range("c5").CopyFromRecordset rst
    
24.         End With
    
25.         rst.Close:    conn.Close:    Set conn = Nothing:    Set rst = Nothing
    
26.     End If
    
27. End Sub
    

复制代码

翁知江安

Sub tq1()
Dim i, t, irow
t = Timer
Dim ar
Dim d As Object
Set d = CreateObject("scripting.dictionary")
irow = Sheets("原料出入明细").[b65536].End(xlUp).Row
ar = Sheets("原料出入明细").Range("a1:g" & irow)
For i = 8 To irow
   If ar(i, 2) = Sheets("B").[c3] And ar(i, 4) = Sheets("B").[d3] Then
      d(ar(i, 7)) = ""
    End If
Next
   Sheets("B").[c5].Resize(1000, 1).ClearContents
   If d.Count > 0 Then
   Sheets("B").[c5].Resize(d.Count, 1) = WorksheetFunction.Transpose(d.keys)
   End If
MsgBox Timer - t
MsgBox "ok"
End Sub

翁知江安

供参考，欢迎批评指正

gwjkkkkk

SQL还是最简单的。。。