多列匹配

lushang2018

lushang2018

1. Sub 测试()
   
2.     Dim i%, j%, arr, brr
   
3.     Dim rng As Range, sht As Worksheet, wbk As Workbook
   
4.     Dim dic As Object, key, keys, items
   
5.     Set dic = CreateObject("scripting.dictionary")
   
6.     arr = Sheet5.Range("G2:M" & Sheet5.Cells(Rows.Count, "G").End(xlUp).Row)
   
7.     ReDim brr(1 To 6)
   
8.     For i = LBound(arr) To UBound(arr)
   
9.         key = arr(i, 1)
   
10.         If Not dic.Exists(key) Then
    
11.             For j = 1 To 6
    
12.                 brr(j) = arr(i, j + 1)
    
13.             Next
    
14.             dic(key) = brr
    
15.         End If
    
16.     Next
    
17.     For i = 2 To Sheet3.Cells(Rows.Count, "AA").End(xlUp).Row
    
18.         key = Sheet3.Cells(i, "AA")
    
19.         Sheet3.Cells(i, "AB").Resize(1, 6) = dic(key)
    
20.     Next
    
21. End Sub
    

复制代码

jjmysjg

saghj 发表于 2024-7-3 13:33
没看懂你的那个。。。

源表与结果表的表头字段顺序不一样，你的代码正确

jjmysjg

quqiyuan 发表于 2024-7-3 13:16
你这个用公式咯
=VLOOKUP($AA2,产品单价!$G:$M,MATCH(AB$1,产品单价!$G$1:$M$1,),)
下拉右拉。。

源表与结果表的表头字段顺序不一样，这个公式添加字段的数字就好了

ykcbf1100

参与一下，字典经典用法之一：一查多

ykcbf1100

字典经典用法之一：一查多

1. Sub ykcbf()   '//2024.7.4  字典一查多
   
2.     Dim arr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     With Sheets("产品单价")
   
6.         r = .Cells(.Rows.Count, "g").End(xlUp).Row
   
7.         arr = .[g1].Resize(r, 7)
   
8.     End With
   
9.     For i = 2 To UBound(arr)
   
10.         s = CStr(arr(i, 1))
    
11.         d(s) = i
    
12.     Next
    
13.     With Sheets("订单明细")
    
14.         r = .Cells(.Rows.Count, "aa").End(xlUp).Row
    
15.         brr = .[aa1].Resize(r, 7)
    
16.         For i = 2 To UBound(brr)
    
17.             s = CStr(brr(i, 1))
    
18.             If d.Exists(s) Then
    
19.                 For j = 1 To UBound(brr, 2)
    
20.                     brr(i, j) = arr(d(s), j)
    
21.                 Next
    
22.             End If
    
23.         Next
    
24.         .[aa1].Resize(r, 7) = brr
    
25.     End With
    
26.     Set d = Nothing
    
27.     Application.ScreenUpdating = True
    
28.     MsgBox "OK！"
    
29. End Sub
    
30. 
    

复制代码