文本合并的问题

luchao124 · 发表于 2019-12-9 16:58

如图：

要合并的格式请问使用vba 如何实现？

papshaw · 发表于 2019-12-9 17:27

参考此方法。

feiyang8878 · 发表于 2019-12-9 17:50

http://club.excelhome.net/forum. ... ;page=2#pid10155104

参照一下这个吧

huaner0113 · 发表于 2019-12-9 17:59

用字典，就可以了

luchao124 · 发表于 2019-12-10 09:12

feiyang8878 发表于 2019-12-9 17:50
http://club.excelhome.net/forum.php?mod=viewthread&tid=1509168&page=2#pid10155104

谢谢你的指点

luchao124 · 发表于 2019-12-10 09:13

papshaw 发表于 2019-12-9 17:27
参考此方法。

万分感谢您的指点

luchao124 · 发表于 2019-12-10 09:20

谢谢各位的回答，经过查找资料和研究，终于解决了。现将结果分享，供大家一起学习：
Sub 合并同类项()
'原始数据所在工作表对象
Dim oWKSource As Worksheet
Set oWKSource = Worksheets("数据表")
'结果数据所在工作表对象
Dim oWKTarget As Worksheet
Set oWKTarget = Worksheets("合并结果")
Dim oDic As Object
Set oDic = CreateObject("Scripting.Dictionary")
'sID表示数据源中的唯一标识列字段
Dim sID As String
'sItem表示对应的唯一标识列字段的行号
Dim sItem As String
'字典的键值数组
Dim arrKey
With oWKSource
      '先建立唯一标识列字段的行号索引
      For i = 2 To .Range("a" & .Rows.Count).End(xlUp).Row
         sID = .Cells(i, "a")
         With oDic
            If .exists(sID) Then
               sItem = .Item(sID)
               sItem = sItem & "!" & i
               .Item(sID) = sItem
            Else
                  .Add sID, i
            End If
         End With
      Next i
      '给目标工作表先添加列标题
      With oWKTarget
            .Cells.Clear
            arrTitle = Array("项目", "合并值")
            iCol = UBound(arrTitle) + 1
            .Range("a1").Resize(1, iCol) = arrTitle
         End With
      arrKey = oDic.keys
      '合并同类项
      For i = 0 To UBound(arrKey)
         '唯一标识
         sID = arrKey(i)
         sItem = oDic.Item(sID)
         arr = Split(sItem, "!")
         '要合并的同类项
         s1 = ""


         For j = 0 To UBound(arr)
            iRow = arr(j)
            With oWKSource
                  If j = 0 Then
                     s1 = s1 & .Cells(iRow, "B")

                  Else
                     s1 = s1 & "、" & .Cells(iRow, "B")

                  End If
            End With
         Next j
         '输出结果
         With oWKTarget
            .Cells(i + 2, "a") = sID
            .Cells(i + 2, "b") = s1
         .Activate

         End With
      Next i
End With
MsgBox "操作完毕!"
End Sub

合并同类项文本.rar (19.54 KB, 下载次数: 0)

		自动登录	找回密码
密码			免费注册

[求助] 文本合并的问题

最新热点 /1