用VBA代码实现对另一张表中的数据进行匹配

mx178659422 · 发表于 2015-8-21 16:06

如附件内容，将该工作薄中的两张表（即“责任表”和“匹配数据表”）。我知道用常规函数实现是E2单元格=VLOOKUP(B2&C2&D2,匹配数据表!$A:$B,2,0)，下拉填充E2单元格，在将匹配值转换成文本或数值即可。现请教各位大神，如何编写这段VBA代码来实现匹配或者说对号入座？
要求：1,匹配结果为#N/A仍保留。 2,匹配后保留黄色E列的原格式，匹配结果为值。

zhaogang1960 · 发表于 2015-8-21 16:23

字典加数组法速度快，请参考：

Sub 字典法()
Dim arr, brr(), d As Object, i&, s$
Set d = CreateObject("scripting.dictionary")
arr = Sheets("匹配数据表").Range("A1").CurrentRegion
For i = 2 To UBound(arr)
d(arr(i, 1)) = arr(i, 2)
Next
arr = Range("A1").CurrentRegion
ReDim brr(2 To UBound(arr), 1 To 1)
For i = 2 To UBound(arr)
s = arr(i, 2) & arr(i, 3) & arr(i, 4)
If d.Exists(s) Then
brr(i, 1) = d(s)
Else
brr(i, 1) = "#N/A"
End If
Next
Range("E2").Resize(i - 2) = brr
End Sub

复制代码

zhaogang1960 · 发表于 2015-8-21 16:25

请测试附件

附件.rar (56.78 KB, 下载次数: 882)

mx178659422 · 发表于 2015-8-21 18:32

非常感谢您的帮助，受益匪浅。

mx178659422 · 发表于 2015-8-24 14:08

zhaogang1960 发表于 2015-8-21 16:25
请测试附件

请问，如果要限制匹配的行数，代码该怎么改动？例如：该列匹配的结果只截止第30行，30行以后不做匹配。请zhaogang大大指点。

zhaogang1960 · 发表于 2015-8-24 14:19

mx178659422 发表于 2015-8-24 14:08
请问，如果要限制匹配的行数，代码该怎么改动？例如：该列匹配的结果只截止第30行，30行以后不做匹配。请 ...

Sub 字典法()
Dim arr, brr(), d As Object, i&, s$
Set d = CreateObject("scripting.dictionary")
arr = Sheets("匹配数据表").Range("A1").CurrentRegion
For i = 2 To UBound(arr)
      d(arr(i, 1)) = arr(i, 2)
Next
arr = Range("A1").CurrentRegion
ReDim brr(2 To UBound(arr), 1 To 1)
For i = 2 To UBound(arr)
      If i > 30 Then Exit For '新加
      s = arr(i, 2) & arr(i, 3) & arr(i, 4)
      If d.Exists(s) Then
         brr(i, 1) = d(s)
      Else
         brr(i, 1) = "#N/A"
      End If
Next
Range("E2").Resize(i - 2) = brr
End Sub

mx178659422 · 发表于 2015-8-26 11:51

zhaogang1960 发表于 2015-8-24 14:19
Sub 字典法()
Dim arr, brr(), d As Object, i&, s$
Set d = CreateObject("scripting.diction ...

zhaogang大大，再问一个，如果只匹配E10至E30呢？

zhaogang1960 · 发表于 2015-8-26 12:59

mx178659422 发表于 2015-8-26 11:51
zhaogang大大，再问一个，如果只匹配E10至E30呢？

Sub 字典法()
Dim arr, brr(), d As Object, i&, s$
Set d = CreateObject("scripting.dictionary")
arr = Sheets("匹配数据表").Range("A1").CurrentRegion
For i = 2 To UBound(arr)
d(arr(i, 1)) = arr(i, 2)
Next
arr = Range("A10:D30")
ReDim brr(1 To UBound(arr), 1 To 1)
For i = 1 To UBound(arr)
s = arr(i, 2) & arr(i, 3) & arr(i, 4)
If d.Exists(s) Then
brr(i, 1) = d(s)
Else
brr(i, 1) = "#N/A"
End If
Next
Range("E10:E30") = brr
End Sub

复制代码

Cosseven · 发表于 2015-9-27 16:37

zhaogang1960 发表于 2015-8-21 16:23
字典加数组法速度快，请参考：

老师好，看了你的http://club.excelhome.net/thread-1225005-1-1.html这个问题的答案，我有个类似的问题http://club.excelhome.net/thread-1232403-1-1.html，但是不知道怎么从你写的代码修改，请老师指点

wjh98 · 发表于 2017-10-13 10:50

zhaogang1960 发表于 2015-8-26 12:59

我下载试了后，提示无法运行宏，可能是因为该宏在此工作薄中不可用，或者所有的宏都被禁止，我的版本是wps2016抢鲜版。下载安装有vb7.0 ，运行其他的宏还可以，有的则出现此类提示，请教是什么原因呢？

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

[求助] 用VBA代码实现对另一张表中的数据进行匹配