设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 如何拆分并匹配
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 903|回复: 7

[已解决]如何拆分并匹配

[复制链接]
发表于 2022-11-23 23:38 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
请教各位大神，应该如何写VBA代码：
          附件为财务数据表，里面的附表sheet1的E列（Account Combination）由几部分组成：JV   Account    CostCenter   SalesC   Projectc

1. 现在需要把E列拆分，拆分的结果请看附表“拆分结果”，标题从Account Combination 变成几个标题（JV   Account    CostCenter   SalesC   Projectc）

2. 附表“拆分结果” 另外新增了 K列（Region）  、 L列 （Market），这两列是根据拆分后的CostCenter去Vlookup匹配出附表“店铺资料表”的F列（成本中心）对应的 I列（区）和 K列（Description）的





最佳答案
月排行榜 / 总排行榜
excel用账户
2022-11-24 15:49
  1. Sub test()
  2. Dim reg As Object '声明
  3. Set dic = CreateObject("Scripting.Dictionary")
  4. arr = Sheets(3).Range("h2:h" & Sheets(3).UsedRange.Rows.Count) '表3 区号填入arr
  5. Set reg = CreateObject("VBScript.RegExp") '创建正则对象
  6. For I = 2 To Sheets(2).Cells(Rows.Count, 5).End(xlUp).Row '表2 e列循环
  7.     a = Sheets(2).Cells(I, "e")
  8.     With reg
  9.         .Global = True
  10.         .Pattern = "(\w+)-(\w+)-(\w+)-(\w+)-(\w+)-(\w+)-(\w+)-(\w+)-(\w+)"
  11.     End With
  12.     Set mat = reg.Execute(a)
  13.     For Each m In mat '提取Account Combination 到FGHIJ
  14.         Sheets(2).Cells(I, "f") = m.SubMatches(0)
  15.         Sheets(2).Cells(I, "g") = m.SubMatches(1)
  16.         Sheets(2).Cells(I, "h") = m.SubMatches(2)
  17.         Sheets(2).Cells(I, "i") = m.SubMatches(4)
  18.         Sheets(2).Cells(I, "j") = m.SubMatches(7)
  19.     Next
  20.     For j = LBound(arr, 1) To UBound(arr, 1) '表2h列匹配区号
  21.     If arr(j, 1) = Sheets(2).Cells(I, "h").Value Then
  22.         Sheets(2).Cells(I, "k") = Sheets(3).Cells(j + 1, "i")
  23.         Sheets(2).Cells(I, "l") = Sheets(3).Cells(j + 1, "k")
  24.     End If
  25.     Next
  26. Next
  27. Set mat = Nothing
  28. End Sub
复制代码

discover拆分.rar

42.68 KB, 下载次数: 10
excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
 楼主| 发表于 2022-11-24 09:13 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
关于第二点的匹配：通过拆分后的CostCenter去Vlookup匹配出附表“店铺资料表”的F列（成本中心）对应的 I列（区）和 K列（Description）的，具体细节请看附件
2345截图20221124091033.jpg
2345截图20221124091130.jpg
回复

使用道具 举报

发表于 2022-11-24 15:49 | 显示全部楼层    本楼为最佳答案   
工作中最常用的Excel函数公式，全印在一张鼠标垫上
  1. Sub test()
  2. Dim reg As Object '声明
  3. Set dic = CreateObject("Scripting.Dictionary")
  4. arr = Sheets(3).Range("h2:h" & Sheets(3).UsedRange.Rows.Count) '表3 区号填入arr
  5. Set reg = CreateObject("VBScript.RegExp") '创建正则对象
  6. For I = 2 To Sheets(2).Cells(Rows.Count, 5).End(xlUp).Row '表2 e列循环
  7.     a = Sheets(2).Cells(I, "e")
  8.     With reg
  9.         .Global = True
  10.         .Pattern = "(\w+)-(\w+)-(\w+)-(\w+)-(\w+)-(\w+)-(\w+)-(\w+)-(\w+)"
  11.     End With
  12.     Set mat = reg.Execute(a)
  13.     For Each m In mat '提取Account Combination 到FGHIJ
  14.         Sheets(2).Cells(I, "f") = m.SubMatches(0)
  15.         Sheets(2).Cells(I, "g") = m.SubMatches(1)
  16.         Sheets(2).Cells(I, "h") = m.SubMatches(2)
  17.         Sheets(2).Cells(I, "i") = m.SubMatches(4)
  18.         Sheets(2).Cells(I, "j") = m.SubMatches(7)
  19.     Next
  20.     For j = LBound(arr, 1) To UBound(arr, 1) '表2h列匹配区号
  21.     If arr(j, 1) = Sheets(2).Cells(I, "h").Value Then
  22.         Sheets(2).Cells(I, "k") = Sheets(3).Cells(j + 1, "i")
  23.         Sheets(2).Cells(I, "l") = Sheets(3).Cells(j + 1, "k")
  24.     End If
  25.     Next
  26. Next
  27. Set mat = Nothing
  28. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2022-11-25 09:15 | 显示全部楼层
excel用账户 发表于 2022-11-24 15:49

亲，不行哦，执行代码后没反应

discover拆分 - 副本.rar

35.55 KB, 下载次数: 3
回复

使用道具 举报

发表于 2022-11-25 10:33 | 显示全部楼层
zhong4314 发表于 2022-11-25 09:15
亲，不行哦，执行代码后没反应

你是希望在原来的表格基础上新增列吗，还是生成一个新表
回复

使用道具 举报

 楼主| 发表于 2022-11-25 14:32 | 显示全部楼层
excel用账户 发表于 2022-11-25 10:33
你是希望在原来的表格基础上新增列吗，还是生成一个新表

哦哦，我是希望能够生成一个附表是拆分好的结果，也就是说原来的表格只有sheet1 和店铺资料表两个附表，现在生成一个拆分好的附表
回复

使用道具 举报

发表于 2022-11-25 15:40 | 显示全部楼层
zhong4314 发表于 2022-11-25 14:32
哦哦，我是希望能够生成一个附表是拆分好的结果，也就是说原来的表格只有sheet1 和店铺资料表两个附表， ...
  1. Sub text()
  2. Dim reg As Object '声明
  3. Sheets(1).Copy After:=Sheets(1) '复制表1
  4. Sheets(2).Name = "结果"
  5. Sheets(2).Columns("F:L").Insert Shift:=xlShiftToRight '表2 插入7列
  6. Sheets(2).Range("F4:L4").ColumnWidth = 8.25
  7. Sheets(2).Cells(1, "f") = "JV"
  8. Sheets(2).Cells(1, "g") = "Account"
  9. Sheets(2).Cells(1, "h") = "CostCent"
  10. Sheets(2).Cells(1, "i") = "SalesC"
  11. Sheets(2).Cells(1, "j") = "ProjectC"
  12. Sheets(2).Cells(1, "k") = "Region"
  13. Sheets(2).Cells(1, "l") = "Market"
  14. arr = Sheets(3).Range("h2:h" & Sheets(3).UsedRange.Rows.Count) '表3 区号填入arr
  15. Set reg = CreateObject("VBScript.RegExp") '创建正则对象
  16. For I = 2 To Sheets(2).Cells(Rows.Count, 5).End(xlUp).Row '表2 e列循环
  17.     a = Sheets(2).Cells(I, "e")
  18.     With reg
  19.         .Global = True
  20.         .Pattern = "(\w+)-(\w+)-(\w+)-(\w+)-(\w+)-(\w+)-(\w+)-(\w+)-(\w+)"
  21.     End With
  22.     Set mat = reg.Execute(a)
  23.     For Each m In mat '提取Account Combination 到FGHIJ
  24.         Sheets(2).Cells(I, "f") = m.SubMatches(0)
  25.         Sheets(2).Cells(I, "g") = m.SubMatches(1)
  26.         Sheets(2).Cells(I, "h") = m.SubMatches(2)
  27.         Sheets(2).Cells(I, "i") = m.SubMatches(4)
  28.         Sheets(2).Cells(I, "j") = m.SubMatches(7)
  29.     Next
  30.     For j = LBound(arr, 1) To UBound(arr, 1) '表2h列匹配区号
  31.     If arr(j, 1) = Sheets(2).Cells(I, "h").Value Then
  32.         Sheets(2).Cells(I, "k") = Sheets(3).Cells(j + 1, "i")
  33.         Sheets(2).Cells(I, "l") = Sheets(3).Cells(j + 1, "k")
  34.     End If
  35.     Next
  36. Next
  37. Set mat = Nothing
  38. End Sub
复制代码


评分

参与人数 1学分 +1 收起 理由
zhong4314 + 1 学习了

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2022-11-25 22:04 | 显示全部楼层
excel用账户 发表于 2022-11-25 15:40

谢谢亲，辛苦了
回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-4-20 12:17 , Processed in 0.412610 second(s), 14 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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