VBA合并行

Question

Excel数据有7列。我希望仅当多行中A＆amp; B＆amp; C＆amp; D＆amp; E＆amp; F的值相同时才合并行。 G中的值应在合并行中用逗号分隔。 实施例 -

原始数据

已处理数据

我不是开发人员，所以请耐心等待。

Answer 1

假设您的数据已正确排序，这里是合并用户名的代码：

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                    |
+--------+---------+---------+---------+---------+------------+------------------------+

Answer 2

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

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