Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 1777|回复: 5

[已解决]汇总相同项后面的文本

[复制链接]
发表于 2016-6-1 16:33 | 显示全部楼层 |阅读模式
本帖最后由 billyzhang0609 于 2016-6-2 09:38 编辑

如何汇总相同项后面的文本,将这些文本填在一个格子里;
附件在四楼,发了一晚上,早上终于成功了。
最佳答案
2016-6-2 09:28
  1. Sub tt()
  2.     arr = [a1].CurrentRegion
  3.     Set d = CreateObject("scripting.dictionary")
  4.     For i = 2 To UBound(arr)
  5.         x = arr(i, 1)
  6.         If Not d.exists(x) Then
  7.             d(x) = arr(i, 2)
  8.         Else
  9.             If InStr("," & d(x) & ",", "," & arr(i, 2) & ",") = 0 Then d(x) = d(x) & "," & arr(i, 2)
  10.         End If
  11.     Next
  12.     [g2].Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
  13. End Sub
复制代码
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
 楼主| 发表于 2016-6-1 16:39 | 显示全部楼层
发不了附件了,回去用自己电脑发。。
回复

使用道具 举报

 楼主| 发表于 2016-6-1 16:56 | 显示全部楼层
回复

使用道具 举报

 楼主| 发表于 2016-6-2 08:47 | 显示全部楼层
昨天网页开不开,接昨天,看看附件有没有发送成功?

汇总相同项后面的文本.zip

851.34 KB, 下载次数: 5

回复

使用道具 举报

发表于 2016-6-2 09:22 | 显示全部楼层
billyzhang0609 发表于 2016-6-2 08:47
昨天网页开不开,接昨天,看看附件有没有发送成功?

Sub Hz()
    Dim Arr, Dic
    Set Dic = CreateObject("Scripting.Dictionary")
    Arr = [a1].CurrentRegion
    For i = 2 To UBound(Arr)
        If Not Dic.exists(Arr(i, 1)) Then
            Dic(Arr(i, 1)) = Arr(i, 2)
        Else
            Dic(Arr(i, 1)) = Dic(Arr(i, 1)) & "," & Arr(i, 2)
        End If
    Next
    ReDim brr(0 To Dic.Count - 1, 1 To 2)
    For i = 0 To Dic.Count - 1
        brr(i, 1) = Dic.keys()(i)
        brr(i, 2) = Dic.items()(i)
    Next
    [g2].Resize(Dic.Count - 1, 2) = brr
    MsgBox "提取完成"
End Sub
回复

使用道具 举报

发表于 2016-6-2 09:28 | 显示全部楼层    本楼为最佳答案   
  1. Sub tt()
  2.     arr = [a1].CurrentRegion
  3.     Set d = CreateObject("scripting.dictionary")
  4.     For i = 2 To UBound(arr)
  5.         x = arr(i, 1)
  6.         If Not d.exists(x) Then
  7.             d(x) = arr(i, 2)
  8.         Else
  9.             If InStr("," & d(x) & ",", "," & arr(i, 2) & ",") = 0 Then d(x) = d(x) & "," & arr(i, 2)
  10.         End If
  11.     Next
  12.     [g2].Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
  13. End Sub
复制代码

汇总相同项后面的文本.rar

908.46 KB, 下载次数: 5

回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-28 19:46 , Processed in 0.327988 second(s), 9 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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