字典多个关键字匹配怎么优化代码,谢谢！

feixiangye

想要左边的关键字匹配到对应右边的单元格中,求助字典该怎么优化(原数据有几千行),谢谢！

Sub Rev()
Dim d, ar
Set d = CreateObject("Scripting.Dictionary")
ar = [A1].CurrentRegion
For i = 2 To UBound(ar)
      d(ar(i, 1) & ar(1, 3) & ar(i, 2)) = ar(i, 3)
Next i
For i = 2 To Cells(Rows.Count, 8).End(xlUp).Row
For j = 9 To Cells(1, Columns.Count).End(xlToLeft).Column
        s = Cells(i, 8) & Cells(1, j)
        If d.exists(s) Then Cells(i, j) = d(s)
Next j, i
End Sub

关键字1	关键字2	1	2	3			关键字	B1	B2	B3	B4	B5	B6
A	B1	200	201	202			A1	200	290	380	470	560	650
A	B2	290	203	370			A2
A	B3	380	205	538			A3
A	B4	470	207	706
A	B5	560	209	874
A	B6	650	211	1042

这个是昵称吗

这样不是更方便吗

1. Sub nc()
   
2. Dim ar
   
3. ar = Range([c2], Cells([c2].End(xlDown).Row, "e"))
   
4. [I2].Resize(UBound(ar, 2), UBound(ar)) = Application.Transpose(ar)
   
5. End Sub

复制代码

opiona

1.     Set SH1 = Worksheets("Sheet1")
   
2.     Str_coon = "HDR=yes';Data Source =" & ThisWorkbook.FullName     '//OFFICE2003，2007 通用
   
3.     StrA = ""
   
4.     For ICOL = 3 To 5
   
5.         If StrA <> "" Then StrA = StrA & " UNION ALL "
   
6.         StrA = StrA & "SELECT 关键字1,关键字2"
   
7.         StrA = StrA & ",'" & SH1.Cells(1, ICOL).Value & "' AS 排序"
   
8.         StrA = StrA & ",[" & SH1.Cells(1, ICOL).Value & "] AS 数值"
   
9.         StrA = StrA & " FROM [" & SH1.Name & "$A:G]"
   
10.         StrA = StrA & " WHERE NOT 关键字1 IS NULL"
    
11.     Next
    
12.    
    
13.     Rem StrSQL2 = "TRANSFORM SUM(数量) SELECT 品类 FROM [" & sh1.Name & "$] GROUP BY 品类 PIVOT 月份"
    
14.     StrSQL = ""
    
15.     StrSQL = StrSQL & "TRANSFORM SUM(数值)"
    
16.     StrSQL = StrSQL & "SELECT 关键字1 & 排序 AS 关键字"
    
17.     StrSQL = StrSQL & " FROM (" & StrA & ")"
    
18.     StrSQL = StrSQL & " GROUP BY 关键字1,排序"
    
19.     StrSQL = StrSQL & " PIVOT 关键字2"
    
20.    
    
21.     SQLARR = GET_SQL_To_Arr(StrSQL, Str_coon, True)
    
22.     SH1.Range("H1:AZ65536").ClearContents
    
23.     SH1.Range("H1").Resize(UBound(SQLARR, 1) + 1, UBound(SQLARR, 2) + 1) = SQLARR

复制代码

chxw68

1. Sub MPS_VS_Rev()
   
2.   Dim d, ar, cSh$
   
3.   Set d = CreateObject("Scripting.Dictionary")
   
4.   ar = [A1].CurrentRegion
   
5.   For i = 2 To UBound(ar)
   
6.     For j = 3 To UBound(ar, 2)
   
7.       xm = ar(i, 1) & ar(1, j) & ar(i, 2)
   
8.       d(xm) = ar(i, j)
   
9.     Next
   
10.   Next
    
11.   For i = 2 To Cells(Rows.Count, 8).End(xlUp).Row
    
12.     For j = 9 To Cells(1, Columns.Count).End(xlToLeft).Column
    
13.       xm = Cells(i, 8) & Cells(1, j)
    
14.       If d.exists(xm) Then
    
15.         Cells(i, j) = d(xm)
    
16.       End If
    
17.     Next
    
18.   Next
    
19. End Sub
    
20. 
    

复制代码

chxw68

详见附件。

opiona

QQ14885553.rar (23.32 KB, 下载次数: 22)

2018-7-12 11:56 上传

点击文件名下载附件

SQL 转置函数：TRANSFORM

feixiangye

chxw68 发表于 2018-7-12 11:55

老师您好,   如果列号是3,6,8这样的无规律固定的3列或更多固定列，For j = 3 To UBound(ar, 2)
这句代码该怎么改,谢谢！

chxw68

feixiangye 发表于 2018-7-12 12:10
老师您好,   如果列号是3,6,8这样的无规律固定的3列或更多固定列，For j = 3 To UBound(ar, 2)
这句代码 ...

for each y in array(3,6,8)

lsc900707

1. Sub MPS_VS_Rev()
   
2.     Dim d, ar, br
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     ar = [a1].CurrentRegion
   
5.     For i = 2 To UBound(ar)
   
6.         For j = 3 To UBound(ar, 2)
   
7.             s = ar(i, 1) & ar(1, j) & ar(i, 2)
   
8.             d(s) = ar(i, j)
   
9.         Next
   
10.     Next
    
11.     br = [h1].CurrentRegion
    
12.     For i = 2 To UBound(br)
    
13.         For j = 2 To UBound(br, 2)
    
14.             s = br(i, 1) & br(1, j)
    
15.             br(i, j) = d(s)
    
16.         Next
    
17.     Next
    
18.     [h1].CurrentRegion = br
    
19. End Sub

复制代码

lsc900707

附件供测试：