[已解决]多条件查找引用

jordanlive

目前只是一个条件就可以读取了。请高手帮忙修改下。需要满足引用表中B列和C列的和数据表中的B列和C列内容相同取值。

最佳答案

月排行榜 / 总排行榜

hasyh2008

2022-5-4 10:20

Sub TEST()
    On Error Resume Next
    Dim Arr, Brr, S%, I%
    Dim d, T
    T = Timer
    If Sheets("引用表").Range("H2") = "数据1" Then
      S = 3
    ElseIf Sheets("引用表").Range("H2") = "数据2" Then
      S = 4
    Else
      Exit Sub
    End If
    Set d = CreateObject("scripting.dictionary")
    Arr = Sheets("数据表").Range("B1:E" & Sheets("数据表").Range("B65536").End(3).Row)
    For I = 2 To UBound(Arr)
        d(Arr(I, 1) & Arr(I, 2)) = d(Arr(I, 1) & Arr(I, 2)) + Arr(I, S)
    Next
    Brr = Sheets("引用表").Range("B1:D" & Sheets("引用表").Range("B65536").End(3).Row)

    For I = 2 To UBound(Brr)
        Brr(I, 3) = d(Brr(I, 1) & Brr(I, 2))
        If d(Brr(I, 1) & Brr(I, 2)) = 0 Then Brr(I, 3) = "无"
     Next
    Sheets("引用表").Range("B1").Resize(UBound(Brr), 3) = Brr
    MsgBox ("用时" & Format(Timer - T, "0.000") & "秒")
End Sub

跳转到最佳答案楼层

hasyh2008

Sub TEST()
    On Error Resume Next
    Dim Arr, Brr, S%, I%
    Dim d, T
    T = Timer
    If Sheets("引用表").Range("H2") = "数据1" Then
      S = 3
    ElseIf Sheets("引用表").Range("H2") = "数据2" Then
      S = 4
    Else
      Exit Sub
    End If
    Set d = CreateObject("scripting.dictionary")
    Arr = Sheets("数据表").Range("B1:E" & Sheets("数据表").Range("B65536").End(3).Row)
    For I = 2 To UBound(Arr)
        d(Arr(I, 1) & Arr(I, 2)) = d(Arr(I, 1) & Arr(I, 2)) + Arr(I, S)
    Next
    Brr = Sheets("引用表").Range("B1:D" & Sheets("引用表").Range("B65536").End(3).Row)

    For I = 2 To UBound(Brr)
        Brr(I, 3) = d(Brr(I, 1) & Brr(I, 2))
        If d(Brr(I, 1) & Brr(I, 2)) = 0 Then Brr(I, 3) = "无"
     Next
    Sheets("引用表").Range("B1").Resize(UBound(Brr), 3) = Brr
    MsgBox ("用时" & Format(Timer - T, "0.000") & "秒")
End Sub