ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

   
EH云课堂-专业的职场技能充电站 永久免费,网表让Excel秒变数据库 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel函数公式学习大典 高效办公必会的Office实战技巧 免费下载Excel行业应用视频
300集Office 2010微视频教程 Tableau-数据可视化工具 ExcelHome出品 - VBA代码宝免费下载 13门Excel免费公开课任你学
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 免费的Excel考勤计算系统
查看: 496|回复: 11

[求助] 字典多个关键字匹配怎么优化代码,谢谢!

[复制链接]

TA的精华主题

TA的得分主题

发表于 2018-7-12 11:38 | 显示全部楼层 |阅读模式

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

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
关键字B1B2B3B4B5B6
AB1
200
201
202
A1
200
290
380
470
560
650
AB2
290
203
370
A2
AB3
380
205
538
A3
AB4
470
207
706
AB5
560
209
874
AB6
650
211
1042

新建 WinRAR ZIP 压缩文件.zip

14.02 KB, 下载次数: 7

字典优化

TA的精华主题

TA的得分主题

发表于 2018-7-12 11:51 | 显示全部楼层
这样不是更方便吗
  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
复制代码

TA的精华主题

TA的得分主题

发表于 2018-7-12 11:54 | 显示全部楼层
  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
复制代码

TA的精华主题

TA的得分主题

发表于 2018-7-12 11:55 | 显示全部楼层
  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

复制代码

评分

参与人数 2鲜花 +4 收起 理由
雨夜下雨 + 2 优秀作品
feixiangye + 2 感谢帮助

查看全部评分

TA的精华主题

TA的得分主题

发表于 2018-7-12 11:56 | 显示全部楼层
详见附件。

3个key值.rar

15.89 KB, 下载次数: 26

评分

参与人数 1鲜花 +2 收起 理由
feixiangye + 2 感谢帮助

查看全部评分

TA的精华主题

TA的得分主题

发表于 2018-7-12 11:56 | 显示全部楼层

TRANSFORM

本帖最后由 opiona 于 2018-7-19 20:47 编辑

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

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-7-12 12:10 | 显示全部楼层

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

TA的精华主题

TA的得分主题

发表于 2018-7-12 12:42 | 显示全部楼层
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)

TA的精华主题

TA的得分主题

发表于 2018-7-12 12:48 | 显示全部楼层
本帖最后由 lsc900707 于 2018-7-12 12:51 编辑
  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
复制代码

评分

参与人数 1鲜花 +2 收起 理由
feixiangye + 2 感谢帮助

查看全部评分

TA的精华主题

TA的得分主题

发表于 2018-7-12 12:49 | 显示全部楼层
本帖最后由 lsc900707 于 2018-7-12 12:52 编辑

附件供测试:

0712004.rar

16.59 KB, 下载次数: 15

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,高效办公专列,每天发车

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2018-12-14 18:11 , Processed in 0.097207 second(s), 13 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 2001-2017 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表