[已解决]相同名称对应的明细合并在一个单元格内

水水

请问如何将相同名称对应的明细合并在一个单元格内，单元格只占一格（非几个单元格合并状态），谢谢！

明细

名称	地区明细
A001豆豆	北京
A001豆豆	广州
A001豆豆	杭州
A001豆豆	青岛
A001豆豆	上海
A001豆豆	沈阳
A001豆豆	西安

结果

名称	地区明细
A001豆豆	北京;广州;杭州;青岛;上海;沈阳;西安

vacuAhcS.rar (3.8 KB, 下载次数: 12)

2010-6-17 13:59 上传

点击文件名下载附件
相同名称对应的明细合并在一个单元格内

最佳答案

月排行榜 / 总排行榜

amulee

2010-6-17 14:47

Sub 合并()
    Dim ArrYS, ArrJG
    Dim d
    Dim i&, K&, Temp
    Set d = CreateObject("Scripting.Dictionary")
    ArrYS = Range("A4:B" & Range("A65536").End(xlUp).Row)
    ReDim ArrJG(1 To 2, 1 To 1)
    For i = 1 To UBound(ArrYS)
        If Not d.exists(ArrYS(i, 1)) Then
            K = K + 1
            d(ArrYS(i, 1)) = K
            ReDim Preserve ArrJG(1 To 2, 1 To K)
            ArrJG(1, K) = ArrYS(i, 1)
        End If
        Temp = d(ArrYS(i, 1))
        ArrJG(2, Temp) = ArrJG(2, Temp) & ";" & ArrYS(i, 2)
    Next i
    For i = 1 To UBound(ArrJG, 2)
        ArrJG(2, i) = Right(ArrJG(2, i), Len(ArrJG(2, i)) - 1)
    Next i
    Range("D4:E65536").ClearContents
    Range("D4").Resize(UBound(ArrJG, 2), 2) = Application.Transpose(ArrJG)
End Sub

跳转到最佳答案楼层

nichangdong

看一下合适不，把要的粘贴出来，记得要用选择性粘贴，多余的删除掉就ＯＫ

DUcRfCM2.rar (5.08 KB, 下载次数: 7)

2010-6-17 14:19 上传

点击文件名下载附件
相同名称对应的明细合并在一个单元格内

[此贴子已经被作者于2010-6-17 14:26:42编辑过]

jsnjwaq

在C4输入=IF(A3=A4,C3&","&B4,B4),然后再把你需要的那个单元格的内容复制粘贴,一下子得出那个效果,我不会

[em04]

那么的帅

写了2个自定义函数，一个是提取不重复的名称，一个是合并相同的名称。

 

PG9Fb1Ec.rar (9.92 KB, 下载次数: 11)

2010-6-17 14:28 上传

点击文件名下载附件
相同名称对应的明细合并在一个单元格内

ykfexcel

学习学习

 

[em01][em01][em01]

水水

谢谢楼上三位[em23]，希望能用VBA来解决，直接达到效果，因为数据量每期在几万，一个ID对应多个城市大概在50左右。数据量太大，运行时个问题。

[此贴子已经被作者于2010-6-17 14:32:00编辑过]

nichangdong

QUOTE:

以下是引用水水在2010-6-17 14:31:00的发言：
谢谢楼上三位[em23]，希望能用VBA来解决，直接达到效果，因为数据量每期在几万，一个ID对应多个城市大概在50左右。数据量太大，运行时个问题。

用ＶＢＡ　，那么的帅那个不是用ＶＢＡ做出来的吗，你看一下

[此贴子已经被作者于2010-6-17 14:47:35编辑过]

amulee

Sub 合并()
    Dim ArrYS, ArrJG
    Dim d
    Dim i&, K&, Temp
    Set d = CreateObject("Scripting.Dictionary")
    ArrYS = Range("A4:B" & Range("A65536").End(xlUp).Row)
    ReDim ArrJG(1 To 2, 1 To 1)
    For i = 1 To UBound(ArrYS)
        If Not d.exists(ArrYS(i, 1)) Then
            K = K + 1
            d(ArrYS(i, 1)) = K
            ReDim Preserve ArrJG(1 To 2, 1 To K)
            ArrJG(1, K) = ArrYS(i, 1)
        End If
        Temp = d(ArrYS(i, 1))
        ArrJG(2, Temp) = ArrJG(2, Temp) & ";" & ArrYS(i, 2)
    Next i
    For i = 1 To UBound(ArrJG, 2)
        ArrJG(2, i) = Right(ArrJG(2, i), Len(ArrJG(2, i)) - 1)
    Next i
    Range("D4:E65536").ClearContents
    Range("D4").Resize(UBound(ArrJG, 2), 2) = Application.Transpose(ArrJG)
End Sub

帅

阿木[em02][em02][em02]

nichangdong

阿木老师来了[em01][em01]