如何实现跨多个表的vlookup查询，如何用vba实现

paulliukina · 发表于 2017-10-18 16:54

之前的公式版发过，因为返回值里面有文本，所以发到vba这里问问，请高手指点下

附件里面表test1中的数据要在后面不同的表中进行查询，先根据column A里面的名称定为查询所对应名称的表，然后再在相对应的表中根据column B的值查询，返回所对应表中的值
之前想到一个方法就是用iferror函数进行嵌套，
=IFERROR(VLOOKUP($B2;'GE-SV'!$A:$L;COLUMN(B1);FALSE);VLOOKUP($B2;'GE-SH'!$A:$L;COLUMN(B1);FALSE))
不过由于表的数量太多，公式写起来太复杂，需要套很多层，用vba有没有简单的方法，请高手指点下

paulliukina · 发表于 2017-10-19 15:46

有没有高手能给点思路，好像vba也可以用公式 WorksheetFunction.VLookup

microyip · 发表于 2017-10-19 15:48

paulliukina 发表于 2017-10-19 15:46
有没有高手能给点思路，好像vba也可以用公式 WorksheetFunction.VLookup

在VBA里不使用Vlookup，你可以参考http://club.excelhome.net/thread-1310803-1-1.html

jsgj2023 · 发表于 2017-10-19 16:35

请见附件！！！

paulliukina · 发表于 2017-10-19 18:48

jsgj2023 发表于 2017-10-19 16:35
请见附件！！！

多谢版主，还是有些问题，貌似只在字典里面查询了GE-SV这个key值的相关值， f8了一下，发现很多明明在之前的已经通过数组存在字典了可是读不出来，比如 y=4 时 sbr="CTRL-LT7CPPB，PAAJ115853" ，难道是key的定义有问题？

With Sheets("TEST1")
      .Range("e2:q65535").ClearContents
      brr = .Range("a1").CurrentRegion
      For y = 2 To UBound(brr)
         sbr = brr(y, 1) & "," & brr(y, 2)
         If d.exists(sbr) Then
            .Cells(y, 5).Resize(1, 11) = d(sbr)
         End If
      Next
End With

paulliukina · 发表于 2017-10-19 19:08

jsgj2023 发表于 2017-10-19 16:35
请见附件！！！

又研究了一下貌似是这个的问题，如果列数小于12的表，存数组时会造成subscript out of range
d(s) = Array(arr(x, 2), arr(x, 3), arr(x, 4), arr(x, 5), arr(x, 6), arr(x, 7), arr(x, 8), arr(x, 9), arr(x, 10),arr(x, 11), arr(x, 12))

paulliukina · 发表于 2017-10-19 19:50

microyip 发表于 2017-10-19 15:48
在VBA里不使用Vlookup，你可以参考http://club.excelhome.net/thread-1310803-1-1.html

多谢，您的帖子很有帮助，因为最近在学access和sql，已经收藏了，回头好好研究下

袁振涛 · 发表于 2017-10-19 20:59

Sub Adele()
Dim d As Object, d1 As Object, sht As Worksheet
Dim Arr, Brr, Crr, strSheetName$, strTypaName$
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
Arr = [a1].CurrentRegion
For i = 2 To UBound(Arr)
strTypaName = CStr(Arr(i, 1))
If Not d.exists(strTypaName) Then
Set d(strTypaName) = CreateObject("scripting.dictionary")
End If
d(strTypaName)(CStr(Arr(i, 2))) = i - 1
Next
For i = 5 To UBound(Arr, 2)
d1(Arr(1, i)) = i - 4
Next
ReDim Brr(1 To UBound(Arr), 1 To UBound(Arr, 2) - 4)
For Each sht In Worksheets
strSheetName = sht.Name
If strSheetName <> "TEST1" And sht.[a65536].End(3).Row > 1 And d.exists(strSheetName) Then
Crr = sht.Range("a1").CurrentRegion
For i = 2 To UBound(Crr)
If d(strSheetName).exists(CStr(Crr(i, 1))) Then
For j = 2 To UBound(Crr, 2)
If d1.exists(Crr(1, j)) Then
Brr(d(strSheetName)(CStr(Crr(i, 1))), d1(Crr(1, j))) = Crr(i, j)
End If
Next
End If
Next
Erase Crr
End If
Next
[e2].Resize(UBound(Arr, 1), UBound(Arr, 2) - 4) = Brr
Application.ScreenUpdating = True
End Sub

复制代码

jsgj2023 · 发表于 2017-10-20 08:55

修改如下:
Sub Adele()
Dim d  As Object, sht As Worksheet
Set d = CreateObject("scripting.dictionary")
For Each sht In Worksheets
      If sht.Name <> "TEST1" Then
         With sht
            arr = .Range("a1").CurrentRegion
            For x = 2 To UBound(arr)
                  s = sht.Name & "," & arr(x, 1)
                  If UBound(arr, 2) > 11 Then
                     d(s) = Array(arr(x, 2), arr(x, 3), arr(x, 4), arr(x, 5), arr(x, 6), arr(x, 7), arr(x, 8), arr(x, 9), arr(x, 10), arr(x, 11), arr(x, 12))
                  Else
                     d(s) = Array(arr(x, 2), arr(x, 3), arr(x, 4), arr(x, 5), arr(x, 6), arr(x, 7), arr(x, 8), arr(x, 9))
                  End If
            Next
         End With
      End If
Next
With Sheets("TEST1")
      .Range("e2:q65535").ClearContents
      brr = .Range("a1").CurrentRegion
      For y = 2 To UBound(brr)
         sbr = brr(y, 1) & "," & brr(y, 2)
         If d.exists(sbr) Then
            .Cells(y, 5).Resize(1, UBound(d(sbr)) + 1) = d(sbr)
         End If
      Next
End With
End Sub

blackttea1 · 发表于 2017-10-20 13:33

做个记号，谢谢

		自动登录	找回密码
密码			免费注册

[求助] 如何实现跨多个表的vlookup查询，如何用vba实现