VBA合併行

Question

Excel數據有7列。我希望行只在A的值合併時在多行中的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

假設你的數據是正確排序，這裏是一個融合了用戶名的密碼：

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