VBA для объединения строк

Данные Excel имеют 7 столбцов. Я хочу, чтобы строки объединялись только тогда, когда значения для A & B & C & D & E & F в нескольких рядах одинаковы. Значения в G должны быть разделены запятой в объединенной строке. Пример-

Необработанные данные

необработанные данные

Обработанные данные

обработанные данные

Я не разработчик, поэтому, пожалуйста, несите меня.

Во-первых, вы должны собирать не дублированные данные, а затем извлекать данные пользователя после сравнения с исходными данными.

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 

Предполагая, что ваши данные отсортированы правильно, вот код, который объединяет имена пользователей:

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

VBA – модульное возведение в степень

Заполнить ячейку текстом, только если пустым

Добавление CSV-файлов с данными того же типа, но с разными именами столбцов

Загрузите CSV-файл в базу данных PHP MySQL без заголовков столбцов

VB.Net: если заявление при условном форматировании

VBA, удаляющее повторяющиеся значения из 2 столбцов

Как группировать строки excel на нескольких уровнях с помощью макроса excel

Преобразование обычного текстового HTML-файла в двоичный Excel 97-2003

Web-Crawler для VBA

Чтобы удалить несколько строк с помощью команды Excel VBA

VBScript и запуск макроса из Excel Excel

Переформатирование некоторых списков рассылки в зависимости от файла excel

Если переменная преобразования линейного программирования> 0, то> = 3000

экспортировать Excel-лист, используя phpexcel для установки строк и столбцов

Хранить строки MATLAB, содержащиеся в массиве ячеек в Excel-таблице

Давайте будем гением компьютера.