请教老师：如何使多次匹配快速完成，谢谢！

qx-liuwx

如题、详见附件，有劳高手！

凌空一羽

1. Sub lkyy()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. ar = Range("q1").CurrentRegion
   
4. For i = 2 To UBound(ar)
   
5.     d(ar(i, 1)) = ar(i, 2)
   
6. Next
   
7. m = Range("a1").End(4).Row
   
8. mm = Range("h1").End(4).Row
   
9. ar1 = Range("a1:d" & m)
   
10. ar2 = Range("h1:k" & mm)
    
11. For i = 2 To m
    
12.     For j = 2 To mm
    
13.         If ar1(i, 1) = ar2(j, 1) Then
    
14.             For k = 2 To 4
    
15.                 ar1(i, k) = d(ar2(j, k))
    
16.             Next
    
17.         End If
    
18.     Next
    
19. Next
    
20. Range("a1").Resize(m, 4) = ar1
    
21. Set d = Nothing
    
22. End Sub

复制代码