[已解决]求：如何按条件将多行文本合并到同一个单元格的VBA代码

lzljxchyh

我有很多类似这样的数据，我希望将相同“姓名”的人，其“借用书目”也合并在同一单元格显示，效果如图。
VBA新手，请各位高手赐教，谢谢！

姓名	借用书目
张三	书名1
李四	书名2
张三	书名3
李四	书名4
张三	书名5

效果：

姓名	借用书目
张三	书名1；书名2；书名5
李四	书名2；书名4

最佳答案

月排行榜 / 总排行榜

today0427

2016-4-30 23:04

我师傅 也写了个，我觉得特别好也很简洁，因为你的数据只有两列，直接用字典就做了，你看看能不能看懂
Sub demo()
    Dim d, ar, i As Long
    Set d = CreateObject("scripting.dictionary")
    ar = Sheets("登记表").Range("a1:b" & Sheets("登记表").Cells(Rows.Count, 1).End(3).Row)
    For i = 1 To UBound(ar)
        If d(ar(i, 1)) = "" Then
            d(ar(i, 1)) = ar(i, 2)
        Else
            d(ar(i, 1)) = d(ar(i, 1)) & ";" & ar(i, 2)
        End If
    Next
    Sheets("汇总表").Range("a1").Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
End Sub

跳转到最佳答案楼层

baksy

附件

lzljxchyh

baksy 发表于 2016-4-28 16:14
附件

谢谢！你的回答，不过我需要的是VBA代码，另外我是想让同一个人借用的书名在同一个单元格内显示，并且各书名之间用分号连接。

爱疯

建议上传excel文档，模拟部分结果

七彩屋

合并到同一个单元格的VBA代码.rar (14.33 KB, 下载次数: 7)

2016-4-28 18:14 上传

点击文件名下载附件

today0427

Sub smhb()
    Dim ro As Integer, dic, k As Integer, h As Integer
    Dim arr, arrs(1 To 100000, 1 To 2)
        Set dic = CreateObject("scripting.dictionary")
        arr = Intersect(Sheets("登记表").UsedRange.Offset(1, 0), Sheets("登记表").UsedRange)
        For ro = 1 To UBound(arr, 1)
            If dic.exists(arr(ro, 1)) Then
                h = dic(arr(ro, 1))
                arrs(h, 2) = arrs(h, 2) & ";" & arr(ro, 2)
            
            Else
                k = k + 1
                dic(arr(ro, 1)) = k
                arrs(k, 1) = arr(ro, 1)
                arrs(k, 2) = arr(ro, 2)
            End If
        Next
        
     Sheets("汇总表").Cells.Clear
     Sheets("登记表").Rows("1:1").Copy Sheets("汇总表").[a1]
     Sheets("汇总表").[a2].Resize(k, 2) = arrs
   
End Sub

today0427

测试一下看对不对

lzljxchyh

today0427 发表于 2016-4-28 18:25
Sub smhb()
    Dim ro As Integer, dic, k As Integer, h As Integer
    Dim arr, arrs(1 To 100000, 1 ...

感谢你的帮助，你的代码完全能达到我的要求。只是我刚接触VBA，水平有限，对数组的应用不是很熟悉，所以看这段代码时有些不理解。
我曾经见到过不是通过数组的方式来编写这段代码的，也能达到同样的要求，但是对具体的语句记不太清了。只记得里面也是用到了FOR循环和IF语句，用到了End(xlUp).Row，然后好象是通过以CELLS（i,j)形式，对其行标进行循环，判断下一行与上一行的相同（即姓名相同）的，将书名合并到同一行。
    只是这样在使用前需要先对数据按姓名进行排序。虽然需要多进行这一步，但是代码看上去好象比较简洁易懂。不知如果在数据已排好序的前提下，能使代码更加简洁些吗？
    不好意思，是我的水平问题，所以有些强人所难了，如果没时间就不必理会了。

lzljxchyh

today0427 发表于 2016-4-28 18:27
测试一下看对不对

感谢你的帮助，你的代码完全能达到我的要求。只是我刚接触VBA，水平有限，对数组的应用不是很熟悉，所以看这段代码时有些不理解。
我曾经见到过不是通过数组的方式来编写这段代码的，也能达到同样的要求，但是对具体的语句记不太清了。只记得里面也是用到了FOR循环和IF语句，用到了End(xlUp).Row，然后好象是通过以CELLS（i,j)形式，对其行标进行循环，判断下一行与上一行的相同（即姓名相同）的，将书名合并到同一行。
    只是这样在使用前需要先对数据按姓名进行排序。虽然需要多进行这一步，但是代码看上去好象比较简洁易懂。不知如果在数据已排好序的前提下，能使代码更加简洁些吗？
    不好意思，是我的水平问题，所以有些强人所难了，如果没时间就不必理会了。

lzljxchyh

七彩屋 发表于 2016-4-28 18:14

感谢你的帮助，你的代码完全能达到我的要求。只是我刚接触VBA，水平有限，对数组的应用不是很熟悉，所以看这段代码时有些不理解。
我曾经见到过不是通过数组的方式来编写这段代码的，也能达到同样的要求，但是对具体的语句记不太清了。只记得里面也是用到了FOR循环和IF语句，用到了End(xlUp).Row，然后好象是通过以CELLS（i,j)形式，对其行标进行循环，判断下一行与上一行的相同（即姓名相同）的，将书名合并到同一行。
    只是这样在使用前需要先对数据按姓名进行排序。虽然需要多进行这一步，但是代码看上去好象比较简洁易懂。不知如果在数据已排好序的前提下，能使代码更加简洁些吗？
    不好意思，是我的水平问题，所以有些强人所难了，如果没时间就不必理会了。