ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH云课堂-专业的职场技能充电站 Excel转在线管理系统,怎么做看这里 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 EH云课堂直播课程免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 1126|回复: 9

[求助] 【已解决】数据源表中D列的关键字,把C列中的数据写入过度表中,不同关键安的写入

[复制链接]

TA的精华主题

TA的得分主题

发表于 2017-6-12 19:50 | 显示全部楼层 |阅读模式
本帖最后由 LMY123 于 2017-6-13 07:34 编辑

根据数据源工作表中D列的关键字,把C列中的数据写入过度表中,不同关键安的写入不同列.rar (20.51 KB, 下载次数: 7)

TA的精华主题

TA的得分主题

发表于 2017-6-12 21:36 | 显示全部楼层
老兄,太高深了

评分

参与人数 1鲜花 +2 收起 理由
LMY123 + 2 谢谢关注

查看全部评分

TA的精华主题

TA的得分主题

发表于 2017-6-12 21:42 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2017-6-12 22:16 | 显示全部楼层
看一下是不是你想要的
  1. Sub tst()
  2. arr = [f1].CurrentRegion
  3. brr = [a1].CurrentRegion
  4. Set d = CreateObject("scripting.dictionary")
  5. Dim crr()
  6. For i = 2 To UBound(arr)
  7. Kwds = arr(i, 1)
  8. For j = 2 To UBound(brr)
  9. If InStr(brr(j, 4), Kwds) > 0 Then
  10. d(Kwds) = d(Kwds) & brr(j, 3) & " "
  11. End If
  12. Next j
  13. n = Application.Ceiling((UBound(Split(Trim(d(Kwds)), " ")) + 1) / 76, 1)
  14. ReDim crr(1 To 76, 1 To n): drr = Split(Trim(d(Kwds)), " ")
  15. For k = 0 To UBound(drr)
  16. If k <= 75 Then
  17. crr(k + 1, 1) = drr(k)
  18. Else
  19. crr(k - 75, 2) = drr(k)
  20. End If
  21. Next
  22. icol = Sheets("过渡表").[a1].End(2).Column + 1
  23. Sheets("过渡表").Cells(1, icol).Resize(76, n) = crr
  24. Next i
  25. End Sub
复制代码

无标题x.png

根据数据源ok.rar

26.45 KB, 下载次数: 2

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-6-12 22:51 | 显示全部楼层
yayahzmeng 发表于 2017-6-12 22:16
看一下是不是你想要的

感谢帮助,明天有花当补上,我没表达清楚,数据连续只是为了方便校对
612.rar (25.59 KB, 下载次数: 2)

TA的精华主题

TA的得分主题

发表于 2017-6-12 22:58 | 显示全部楼层
本帖最后由 yayahzmeng 于 2017-6-13 00:04 编辑

根据新附件,并简化一下代码:
  1. Sub tst()
  2. arr = Range("A1:F" & [b65536].End(3).Row)
  3. Set d = CreateObject("scripting.dictionary")
  4. Dim crr()
  5. For Each Rng In Range("F2:F" & [F65536].End(3).Row)
  6. For i = 2 To UBound(arr)
  7. If InStr(arr(i, 4), Rng.Text) > 0 Then
  8. d(Rng.Text) = d(Rng.Text) + 1
  9. n = Application.Ceiling(d(Rng.Text) / 76, 1)
  10. ReDim Preserve crr(1 To 76, 1 To n)
  11. crr(d(Rng.Text) - (n - 1) * 76, n) = arr(i, 3)
  12. End If
  13. Next
  14. If Sheet9.[a1].CurrentRegion.Columns.Count = 1 Then m = 1 Else: m = Sheet9.[a1].End(2).Column + 1
  15. Sheet9.Cells(1, m).Resize(76, n) = crr
  16. Erase crr
  17. Next
  18. End Sub
复制代码



评分

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

查看全部评分

TA的精华主题

TA的得分主题

发表于 2017-6-12 23:17 | 显示全部楼层
本帖最后由 today0427 于 2017-6-12 23:25 编辑

请查看附件,结果显示在结果表中

3.png

评分

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

查看全部评分

TA的精华主题

TA的得分主题

发表于 2017-6-12 23:58 | 显示全部楼层
本帖最后由 yayahzmeng 于 2017-6-13 00:06 编辑

新附件,请测试

612.rar

24.64 KB, 下载次数: 6

评分

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

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-6-13 07:32 | 显示全部楼层
today0427 发表于 2017-6-12 23:17
请查看附件,结果显示在结果表中

感谢帮助,效果非常好,有花当补上

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-6-13 07:33 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

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

GMT+8, 2019-10-19 14:49 , Processed in 0.081822 second(s), 16 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

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

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

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