行をマージするVBA

Question

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

が適切にソートされ、ここでユーザー名をマージするコードは次のとおりです。

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