以c列为相同项，合并A列B列D列，数据合并并且用换行符分开。

pp777358

求教大佬。实现把A列相同的单元格合并，同时把对应的B列数据合并并且用换行符分开。
Sub zz()
    Dim d, ar
    Application.ScreenUpdating = False
    Set d = CreateObject("Scripting.Dictionary")
    ar = Sheet1.Range("A1").CurrentRegion
    For i = 1 To UBound(ar)
        If InStr(d(ar(i, 1)), ar(i, 2)) = 0 Then
            d(ar(i, 1)) = d(ar(i, 1)) & Chr(10) & ar(i, 2)
        End If
    Next
    With Sheet2
        For Each k In d.keys
            .Cells(2 + n, 1) = k: .Cells(2 + n, 2) = Mid(d(k), 2): n = n + 1
        Next
    End With
    Application.ScreenUpdating = True
End Sub。
我要修改以c列为相同项，合并A列，B列,D列，数据合并并且用换行符分开。代码需要怎么改动呢。
模拟效果

转化成 。请问要怎么修改。

wp231957

既然你还保留纵向格式，那不合并就好了，至于取数据的问题  自然有解决方案

半百

这个是只合并C列的，如果你确定各列的数据都放一个单元格里，那就没必要合并了是吧？
Sub zz()

    Dim d, ar, i, n, k
    Application.ScreenUpdating = False '工作表不隐藏
    Set d = CreateObject("Scripting.Dictionary") '创建一个字典
    ar = Sheet1.Range("c1").CurrentRegion '定义字典
    For i = 1 To UBound(ar)
        d(ar(i, 3)) = d(ar(i, 3)) & Chr(10) & ar(i, 1) & "+" & ar(i, 2) & "+" & ar(i, 4)
    Next
    n = 2
    M = 3
    With Sheet2
        For Each k In d.keys
            A = Split(Mid(d(k), 2), Chr(10))
            For J = 0 To UBound(A)
                n = n + 1
                B = Split(A(J), "+")
                .Cells(n, 1) = B(0)
                .Cells(n, 2) = B(1)
                .Cells(n, 4) = B(2)
            Next
            .Cells(M, 3).Resize(UBound(A) + 1, 1).Merge
            .Cells(M, 3) = k
            M = n + 1
        Next
    End With
    Application.ScreenUpdating = True


End Sub

pp777358

wp231957 发表于 2020-6-16 10:17
既然你还保留纵向格式，那不合并就好了，至于取数据的问题  自然有解决方案

哎，我要用自动发送邮件功能，但是那个只能同一个单元格，所以只能合并在一起。

wang-way

1. Public Sub DoSomethingInActivesheet()
   
2.     '作者  DG-NextSeven
   
3.     '日期  2019年3月23日
   
4.     '说明  处理当前工作表
   
5.                                                                                                                         
   
6.     Dim Wb As Workbook
   
7.     Dim Sht As Worksheet
   
8.     Dim Rng As Range
   
9.     Dim i As Long, j As Long
   
10.     Const HEAD_ROW As Long = 1
    
11.     Dim Dic As Object
    
12.     Set Dic = CreateObject("Scripting.Dictionary")
    
13.                                                                                  
    
14.     Set Wb = Application.ThisWorkbook
    
15.     Set Sht = Wb.ActiveSheet
    
16.     With Sht
    
17.         EndRow = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row
    
18.         For i = HEAD_ROW + 1 To EndRow Step 1
    
19.             Key = .Cells(i, 3).Value
    
20.                                                                                                                                                 
    
21.             If Not Dic.Exists(Key) Then
    
22.                 Dic(Key) = Array(.Cells(i, 1).Value, .Cells(i, 2).Value, .Cells(i, 3).Value, .Cells(i, 4).Value)
    
23. 
    
24.             Else
    
25.                 ar = Dic(Key)
    
26.                 ar(0) = ar(0) & Chr(10) & .Cells(i, 1).Value
    
27.                 ar(1) = ar(1) & Chr(10) & .Cells(i, 2).Value
    
28.                 ar(3) = ar(3) & Chr(10) & .Cells(i, 4).Value
    
29.                 Dic(Key) = ar
    
30.                                                                                                                                                                                 
    
31.             End If
    
32.         Next
    
33.                                                                                                                                                                                 
    
34.         .Range("a1:D1").Copy .Range("f1")
    
35.         Set Rng = .Range("F2")
    
36.         For Each OneK In Dic.keys
    
37.             Lenth = Dic(OneK)
    
38.             Exit For
    
39.         Next
    
40.         columnsize = UBound(Lenth) + 1
    
41.         Set Rng = Rng.Resize(Dic.Count, columnsize)
    
42.         Rng.Value = Application.Rept(Dic.Items, 1)
    
43.                                        
    
44.     End With
    
45.                                                                         
    
46.     Set Wb = Nothing
    
47.     Set Sht = Nothing
    
48.     Set Rng = Nothing
    
49.     Set Dic = Nothing
    
50.                
    
51.                                                                         
    
52. End Sub
    

复制代码

pp777358

wang-way 发表于 2020-6-16 10:59

大佬，牛皮啊（破音）。谢谢，谢谢。

wlh2004

Sub 宏1()
    Range("A2:D11").Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("C2:C11") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A2:D11")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Application.DisplayAlerts = False
        aa = Cells(Rows.Count, 1).End(xlUp).Row
    beg = aa
    For i = aa To 2 Step -1
        If Cells(i, 3) <> Cells(i, 3).Offset(-1, 0) Or i = 2 Then
            endd = i
            Range("c" & endd & ":c" & beg).Merge
            arrb = Range("b" & endd & ":b" & beg)
            Range("b" & endd & ":b" & beg).Merge
            Cells(endd, "b") = Join(Application.Transpose(arrb), Chr(10))
            arra = Range("a" & endd & ":a" & beg)
            Range("a" & endd & ":a" & beg).Merge
            Cells(endd, "a") = Join(Application.Transpose(arra), Chr(10))
            arrd = Range("d" & endd & ":d" & beg)
            Range("d" & endd & ":d" & beg).Merge
            Cells(endd, "d") = Join(Application.Transpose(arrd), Chr(10))
            beg = i - 1
        End If
    Next
End Sub

wlh2004

排序的过程录了个宏,是不是通不过呀

wlh2004

谢谢了,能够通过

pp777358

wang-way 发表于 2020-6-16 10:59

大哥，发现条数多了以后有点问题。会显示错误。有些又是好的