垮文件双条件遍历查找

天真无鞋

麻烦老师帮忙写代码，垮文件双条件遍历查找复制值，详见附加文件说明。

蓝桥玄霜

测试的例子：

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    StrSQL = "Select Distinct 工单,型号,周期 From [Excel 12.0;DataBase=" & ThisWorkbook.Path & "\999\数据库.xlsx].[清单$F2:K]"
    StrSQL = "Select 工单,a.* From [Sheet1$D2:E]a Left Join (" & StrSQL & ")b On a.型号=b.型号 And a.周期=b.周期"
    Range("C3").CopyFromRecordset Cn.Execute(StrSQL)
End Sub

limonet

关键字：left join

天真无鞋

蓝桥玄霜 发表于 2024-9-6 09:56
测试的例子：

谢谢版主，代码没有问题，如果数据库A列到E列之间有数据或者有单元格合并就无法获取，能否帮小白在改改代码，谢谢！

天真无鞋

limonet 发表于 2024-9-6 10:05
关键字：left join

谢谢老师的参与，但是如果在测试工作表，D列和列继续向先输入信息后无法获取，或者改变原来的数据后也不可以。

Qs18

1. Sub qs()
   
2.     Dim arr, wb As Workbook, xb As Workbook, dic As Object, p
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     p = ThisWorkbook.Path & "\999\数据库.xlsx"
   
5.     With GetObject(p)
   
6.     arr = .Sheets(1).UsedRange.Value
   
7.     .Close False
   
8.     End With
   
9.     For i = 3 To UBound(arr)
   
10.     If Not VBA.IsError(arr(i, 2)) Then
    
11.         s = arr(i, 2) & "|" & arr(i, 6)
    
12.             dic(s) = arr(i, 1)
    
13.     End If
    
14.     Next
    
15.     Erase arr
    
16.     With Sheet1
    
17.         r = .Cells(Rows.Count, "d").End(3).Row
    
18.         brr = .Range("d3").Resize(r, 2).Value
    
19.         ReDim crr(1 To r, 1 To 1)
    
20.         For i = 1 To UBound(brr)
    
21.         s = brr(i, 1) & "|" & brr(i, 2)
    
22.         If dic.exists(s) Then
    
23.             crr(i, 1) = dic(s)
    
24.         End If
    
25.         Next
    
26.         .Range("c3").Resize(10000, 1).ClearContents
    
27.         .Range("c3").Resize(r, 1) = crr
    
28.     End With
    
29. End Sub
    

复制代码

Qs18

试试..........

Qs18

试试..........

天真无鞋

Qs18 发表于 2024-9-6 12:04
试试..........

谢谢老师，如果在数据库，测试工作表A列E列有数据都情况下无法获取（红色区域），详见下图，如果把A列到E的数据清楚就可以了，重新上传数据库文件。