VBA合并行

Excel数据有7列。 只有当多行中的A＆B＆C＆D＆E＆F的值相同时，我才想要合并行。 G中的值应该用合并行中的逗号分隔。 例-

原始数据

处理的数据

我不是开发者，请耐心等待。

Answer 1

首先，您必须收集未复制的数据，然后在将数据与原始数据进行比较后提取用户数据。

Sub test() Dim vDB, vR(), vR2(), vResult() Dim s As String, s1 As String Dim X As New Collection Dim n As Long, i As Long, k As Long Dim j As Integer, a As Long, cnt As Long Dim Ws As Worksheet, toWs As Worksheet Set Ws = ActiveSheet vDB = Ws.Range("a1").CurrentRegion n = UBound(vDB, 1) 'Collect unique data(not duplicate) On Error Resume Next For i = 1 To n ReDim vR(1 To 6) For j = 1 To 6 vR(j) = vDB(i, j) Next j s = Join(vR, ",") Err.Clear X.Add s, s If Err.Number <> 457 Then k = k + 1 ReDim Preserve vResult(1 To 7, 1 To k) For j = 1 To 6 vResult(j, k) = vDB(i, j) Next j End If Next i 'After compare unique data with orginal data, get data of User For i = 1 To k cnt = 0 ReDim vR(1 To 6) For j = 1 To 6 vR(j) = vResult(j, i) Next j s = Join(vR, ",") For a = 1 To n ReDim vR(1 To 6) For j = 1 To 6 vR(j) = vDB(a, j) Next j s1 = Join(vR, ",") If s = s1 Then cnt = cnt + 1 ReDim Preserve vR2(1 To cnt) vR2(cnt) = vDB(a, 7) End If Next a vResult(7, i) = Join(vR2, ",") ReDim vR2(1 To 1) Next i Set toWs = Sheets.Add '<~~ change to your sheet : set tows = Sheets("Sheet2") With toWs .Range("a1").Resize(k, 7) = WorksheetFunction.Transpose(vResult) .Columns.AutoFit End With End Sub 

Answer 2

假设您的数据已正确sorting，以下是合并用户名的代码：

 Sub Merge_Usernames() Dim i As Long, j As Long, last_row As Long Dim b_same As Boolean last_row = Cells(Rows.Count, 1).End(xlUp).Row For i = last_row To 3 Step -1 b_same = True For j = 1 To 6 If Cells(i, j).Value <> Cells(i - 1, j).Value Then b_same = False Exit For End If Next j If b_same Then Cells(i - 1, 7).Value = Cells(i - 1, 7).Value & ", " & Cells(i, 7).Value Rows(i).Delete End If Next i End Sub 

我用你提供的示例数据运行它，这里是输出：

 +--------+---------+---------+---------+---------+------------+------------------------+ | Tenant | Company | Country | Channel | Licence | Expiry | User | +--------+---------+---------+---------+---------+------------+------------------------+ | R1 | xyz | T | VS | SV-OC | 05-10-2017 | christopher33, mfeike | | R1 | xyz | T | VS | PJ-OC | 05-10-2017 | c5311800 | | R2 | pqr | R | PS | PJ-OC | 05-10-2017 | c5195954 | | R2 | pqr | R | PS | SV-OC | 05-10-2017 | c5195954, jonyrebollar | | R2 | pqr | R | PS | SV-OC | 06-10-2017 | bob | | R4 | pqr | R | PS | ST-OC | 06-10-2017 | bob | +--------+---------+---------+---------+---------+------------+------------------------+