[已解决]高效多条件匹配带有重复记录的数据

glhfgtd

工作上需要我在AP表中找出相匹配的EP表的内容。由于数据量的庞大(3万多行)，我用的函数公式引用单元格逐个匹配的方法耗时费力，有时甚至导致Excel无反应重启。所以求教这里的VBA能手帮忙编写一个通过VBA数组在内存中计算匹配的代码程序来解决这个问题。(当然，若有更快速效率的方法，求之不得！！！)

匹配规则：

1）根据AP表A、B、C列的字符串和E列的金额在EP表中进行查询匹配，若在 EP表B列中查找到同时含有AP表A、B、C列的字符串并且EP表D列金额等于AP表E列的金额，(请注意： 因为记录中含有重复数据，所以匹配不是一一对应关系)那么请在AP表的G列返回EP表A列相对应的Key值(重复数据要是第一次匹配到，则返回第一个匹配到的A列Key值，若是第二次匹配到，则返回第二个匹配到的A列Key值… 已匹配过的记录不能再次进行匹配，要是我这里解释的不明白请参见我在AP表I2和J2使用的函数公式)。

2）若规则(1)没有匹配到任何记录，接下来根据AP表D列的号码和E列的金额在EP表中进行查询匹配。若在EP表C列和D列同时匹配到AP表D列、E列的内容，那么请在AP表的G列返回相应的EP表A列的Key值 。(同样，已匹配过的记录不能再次进行匹配)

3）若以上规则(1)、(2)均没能找到其匹配对应项，则在AP表的G列返回空值 。

谢谢

EP_AP Matching.zip (301.04 KB, 下载次数: 21)

2014-9-17 08:04 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

grf1973

2014-9-17 11:09

先来个双循环的

1. Sub 匹配()
   
2.     arr = Sheets("ep").[a1].CurrentRegion
   
3.     brr = Sheets("ap").Range("a1:g" & Sheets("ap").[a65536].End(3).Row)
   
4.     n = UBound(arr)
   
5.     For i = 2 To UBound(brr)
   
6.         str1 = brr(i, 1): str2 = brr(i, 2): str3 = brr(i, 3)
   
7.         am = brr(i, 5)   'amount
   
8.         For j = 2 To n
   
9.             x = arr(j, 2): xam = arr(j, 4)
   
10.             If am = xam Then
    
11.                 If InStr(x, str1) > 0 And InStr(x, str2) > 0 And InStr(x, str3) > 0 Then       '规则1，判断同时含有ABC列字符串
    
12.                     brr(i, 7) = arr(j, 1)
    
13.                     For k = 1 To UBound(arr, 2): arr(j, k) = arr(n, k): Next     '把最后一行移到当前行
    
14.                     n = n - 1         '最后一行减1
    
15.                     GoTo aa
    
16.                 End If
    
17.                
    
18.                 If brr(i, 4) = arr(j, 3) Then        '规则2，判断serial
    
19.                     brr(i, 7) = arr(j, 1)
    
20.                     For k = 1 To UBound(arr, 2): arr(j, k) = arr(n, k): Next        '把最后一行移到当前行
    
21.                     n = n - 1       '最后一行减1
    
22.                     GoTo aa
    
23.                 End If
    
24.             End If
    
25.         Next
    
26. aa:
    
27.     Next
    
28.     Sheets("ap").[g1].Resize(UBound(brr), 1) = Application.Index(brr, , 7)
    
29. End Sub
    

复制代码

跳转到最佳答案楼层

grf1973

先来个双循环的

1. Sub 匹配()
   
2.     arr = Sheets("ep").[a1].CurrentRegion
   
3.     brr = Sheets("ap").Range("a1:g" & Sheets("ap").[a65536].End(3).Row)
   
4.     n = UBound(arr)
   
5.     For i = 2 To UBound(brr)
   
6.         str1 = brr(i, 1): str2 = brr(i, 2): str3 = brr(i, 3)
   
7.         am = brr(i, 5)   'amount
   
8.         For j = 2 To n
   
9.             x = arr(j, 2): xam = arr(j, 4)
   
10.             If am = xam Then
    
11.                 If InStr(x, str1) > 0 And InStr(x, str2) > 0 And InStr(x, str3) > 0 Then       '规则1，判断同时含有ABC列字符串
    
12.                     brr(i, 7) = arr(j, 1)
    
13.                     For k = 1 To UBound(arr, 2): arr(j, k) = arr(n, k): Next     '把最后一行移到当前行
    
14.                     n = n - 1         '最后一行减1
    
15.                     GoTo aa
    
16.                 End If
    
17.                
    
18.                 If brr(i, 4) = arr(j, 3) Then        '规则2，判断serial
    
19.                     brr(i, 7) = arr(j, 1)
    
20.                     For k = 1 To UBound(arr, 2): arr(j, k) = arr(n, k): Next        '把最后一行移到当前行
    
21.                     n = n - 1       '最后一行减1
    
22.                     GoTo aa
    
23.                 End If
    
24.             End If
    
25.         Next
    
26. aa:
    
27.     Next
    
28.     Sheets("ap").[g1].Resize(UBound(brr), 1) = Application.Index(brr, , 7)
    
29. End Sub
    

复制代码

grf1973

请看附件。

grf1973

来个字典的。。。。。。。。

1. Sub 匹配1()
   
2.     arr = Sheets("ep").[a1].CurrentRegion
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     brr = Sheets("ap").Range("a1:g" & Sheets("ap").[a65536].End(3).Row)
   
5.     For i = 2 To UBound(arr)
   
6.         am = arr(i, 4)
   
7.         d(am) = d(am) & "," & i            '把指定amount的行数存入字典
   
8.     Next
   
9.     For i = 2 To UBound(brr)
   
10.         am = brr(i, 5)   'amount
    
11.         If d.exists(am) Then         '对于指定amount
    
12.             xrr = Split(d(am), ",")        '所有行数
    
13.             If UBound(xrr) >= 1 Then
    
14.                 str1 = brr(i, 1): str2 = brr(i, 2): str3 = brr(i, 3)
    
15.                 For k = 1 To UBound(xrr)
    
16.                     j = Val(xrr(k))       '行数
    
17.                     If j > 0 Then
    
18.                         x = arr(j, 2)
    
19.                         If InStr(x, str1) > 0 And InStr(x, str2) > 0 And InStr(x, str3) > 0 Then       '规则1，判断同时含有ABC列字符串
    
20.                             brr(i, 7) = arr(j, 1)
    
21.                             d(am) = Replace(d(am) & ",", "," & j & ",", ",")        '去掉已判断过的
    
22.                             GoTo aa
    
23.                         End If
    
24.                     End If
    
25.                 Next
    
26.                
    
27.                 For k = 1 To UBound(xrr)
    
28.                     j = Val(xrr(k))
    
29.                     If j > 0 Then
    
30.                         x = arr(j, 2)
    
31.                         If brr(i, 4) = arr(j, 3) Then        '规则2，判断serial
    
32.                             brr(i, 7) = arr(j, 1)
    
33.                             d(am) = Replace(d(am) & ",", "," & j & ",", ",")
    
34.                             GoTo aa
    
35.                         End If
    
36.                     End If
    
37.                 Next
    
38.             End If
    
39.         End If
    
40. aa:
    
41.     Next
    
42.     Sheets("ap").[g1].Resize(UBound(brr), 1) = Application.Index(brr, , 7)
    
43. End Sub

复制代码

grf1973

我觉得2楼的代码可能有点问题，某些情况下会把规则2先于规则1的记录给筛选出来。

grf1973

对比着用一下吧，如果数据量大的话，估计代码2要快一些。

glhfgtd

grf1973 发表于 2014-9-17 14:31
对比着用一下吧，如果数据量大的话，估计代码2要快一些。

谢谢您的解答，在实际应用中发现导入了更多的数据后，有的数据文本有英文大小写差异，我把If InStr(x, str1) > 0 改为If InStr(x, str1，1) > 0 进行文本比较，因有的str1为空，得到"类型不匹配"错误，麻烦您帮忙修改一下代码使其能够进行文本比较(忽视大小写的不同)

grf1973

把要对比的全部转换成大写或小写就行了：
str1 = UCase(brr(i, 1)): str2 = UCase(brr(i, 2)): str3 = UCase(brr(i, 3))
......
x = UCase(arr(j, 2))
.....

glhfgtd

grf1973 发表于 2014-9-17 16:07
把要对比的全部转换成大写或小写就行了：
str1 = UCase(brr(i, 1)): str2 = UCase(brr(i, 2)): str3 = UCa ...

谢谢指点，有学了一招。