【已解决】请教老师，如何把相同名称的不同内容合并在一起

vbahappy

    在实际工作中，我经常会遇到这个问题，就是相同的名称，有些内容不同，想把不同的内容合在同一单元格，
并且只保留一行，其他的删除；

鑫尼达

看我的提问，标题里有逆透视的那个

wanao2008

但愿能帮到你：

Sub byWanao()
    With Sheet1
        For x = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
            If .Cells(x, 2) = "" Then Exit For
            For y = .Cells(Rows.Count, 2).End(xlUp).Row To x + 1 Step -1
                If .Cells(x, 2) = .Cells(y, 2) Then
                    .Cells(x, 4) = .Cells(x, 4) & "，" & .Cells(y, 4)
                    .Cells(y, 4).EntireRow.Delete
                End If
            Next
        Next
    End With
End Sub

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("sheet1")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a2:g" & r)
   
9.   End With
   
10.   For i = 1 To UBound(arr)
    
11.     If Not d.exists(arr(i, 2)) Then
    
12.       ReDim brr(1 To UBound(arr, 2))
    
13.       For j = 1 To UBound(arr, 2)
    
14.         brr(j) = arr(i, j)
    
15.       Next
    
16.     Else
    
17.       brr = d(arr(i, 2))
    
18.       brr(4) = brr(4) & "," & arr(i, 4)
    
19.     End If
    
20.     d(arr(i, 2)) = brr
    
21.   Next
    
22.   With Worksheets("sheet2")
    
23.     .UsedRange.Offset(1, 0).Clear
    
24.     .Range("a2").Resize(d.Count, UBound(brr)) = Application.Transpose(Application.Transpose(d.items))
    
25.   End With
    
26. End Sub
    

复制代码

chxw68

详见附件。

vbahappy

chxw68 发表于 2021-7-21 18:43
详见附件。

谢谢chxw68 老师的多次帮助，效果倒是这个效果，但我希望得出的结果覆盖原来的表，而不需要在SHEET2中，可以

vbahappy

我自己改过来了，谢谢老师

chxw68

就改一个字符，楼主要学会自己动手。

kxf1990

学习了

zh1518

Sub TestSub()
    Dim i, j, k, arr, brr, x, y, rng As Range
    Dim dic As Object, key As String, dickeys, Item, dicItems
    Set dic = CreateObject("scripting.dictionary")
    With Sheet1
        arr = .Range("a1:g" & Cells(Rows.Count, "A").End(xlUp).Row)
        ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
        For i = LBound(arr) + 1 To UBound(arr)
            key = arr(i, 2)
            If Not dic.Exists(key) Then
                k = k + 1
                For j = 1 To UBound(brr, 2)
                    brr(k, j) = arr(i, j)
                Next
                dic(key) = dic.Count + 1
            Else
                行号 = dic(key)
                brr(行号, 4) = brr(行号, 4) & "," & arr(i, 4)
            End If
        Next
        .[a2].Resize(1000, 10) = ""
        .[a2].Resize(k, UBound(brr)) = brr
    End With
End Sub