按范围取引用值

42921783

按4个条件匹配：当“结果”表的条件一、二、三与"引用值参考"表的条件一、二、三分别相等时，再看“结果”表条件四，落在"引用值参考"表条件四1、条件四2的哪个范围。

dsmch

1. Sub dsmch()
   
2. Dim arr, brr, d, i&, zf$
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheet2.Range("a1").CurrentRegion
   
5. brr = Sheet1.Range("a1").CurrentRegion
   
6. For i = 2 To UBound(arr)
   
7.     zf = arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3)
   
8.     If Not d.exists(zf) Then d(zf) = i Else d(zf) = d(zf) & "," & i
   
9. Next
   
10. For i = 2 To UBound(brr)
    
11.     zf = brr(i, 1) & "," & brr(i, 2) & "," & brr(i, 3)
    
12.     x = Split(d(zf), ",")
    
13.     For j = 0 To UBound(x)
    
14.         n = x(j)
    
15.         If brr(i, 4) >= arr(n, 4) And brr(i, 4) <= arr(n, 5) Then brr(i, 5) = arr(n, 6): Exit For
    
16.    Next
    
17. Next
    
18. Sheet1.Range("e1").Resize(UBound(brr)) = Application.Index(brr, 0, 5)
    
19. End Sub

复制代码

dsmch

Sub dsmch()
Dim arr, brr, d, i&, zf$
Set d = CreateObject("scripting.dictionary")
arr = Sheet2.Range("a1").CurrentRegion
brr = Sheet1.Range("a1").CurrentRegion
For i = 2 To UBound(arr)
    zf = arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3)
    If Not d.exists(zf) Then d(zf) = i Else d(zf) = d(zf) & "," & i
Next
For i = 2 To UBound(brr)
    zf = brr(i, 1) & "," & brr(i, 2) & "," & brr(i, 3)
    x = Split(d(zf), ",")
    For j = 0 To UBound(x)
        n = x(j)
        If brr(i, 4) >= arr(n, 4) And brr(i, 4) <= arr(n, 5) Then brr(i, 5) = arr(n, 6): Exit For
   Next
Next
Sheet1.Range("e1").Resize(UBound(brr)) = Application.Index(brr, 0, 5)
End Sub

dsmch

………………

xd3210

Sub adotest()
    Dim cnn As Object
    Dim rs As Object
    Dim sql As String
    Set cnn = CreateObject("adodb.connection")
    Set rs = CreateObject("adodb.recordset")
    cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties='excel 12.0;hdr=no;imex=1';data source=" & ThisWorkbook.FullName
    sql = "select b.f6 from [结果$a2:d]a left join [引用值参考$a2:f]b on a.f1=b.f1 and a.f2=b.f2 and a.f3=b.f3 where a.f4 between b.f4 and b.f5"
    rs.Open sql, cnn, 1, 3
    Range("e2").CopyFromRecordset rs
End Sub

xd3210

使用ADO方法，附件已上传，请测试