Совместить два макроса:удаление дубликатов в одном столбце и сбор данных из другого столбца через запятую

Пользователь

Сообщений: 19 Регистрация: 26.03.2014

13.01.2022 17:07:28

Как вы мне уже подсказали с двумя макросами, мне нужно их совместить, что бы был следующий результат:
Необходимо по столбцу "sku" найти дубликаты и по столбцу "categories" этих дубликатов, соединить текст в ячейках через "," без пробелов. Товары дубликаты (строки) в ячейках которых остались пустые значения и просто товары которые повторяются по "sku" и "categories" - удалить.

Код

Sub Макрос1()
    ActiveSheet.Columns("C:C").Replace What:=" ", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    ActiveSheet.UsedRange.RemoveDuplicates Columns:=Array(3, 4), Header:=xlYes
End Sub

Код

Sub Соединить_через_запятую()
Const sDELIM As String = ""     'символ-разделитель
Dim rCell As Range
Dim sMergeStr As String
If TypeName(Selection) <> "Range" Then Exit Sub   'если выделены не ячейки - выходим
With Selection
For Each rCell In .Cells
sMergeStr = sMergeStr & "," & sDELIM & rCell.Text  'собираем текст из ячеек
Next rCell
Application.DisplayAlerts = False   'отключаем стандартное предупреждение о потере текста
.Merge Across:=False                'объединяем ячейки
Application.DisplayAlerts = True
.Item(1).Value = Mid(sMergeStr, 2 + Len(sDELIM))    'добавляем к объед.ячейке суммарный текст
.MergeCells = True
End With
Selection.UnMerge
End Sub

Спасибо!

Прикрепленные файлы

товары-планета-пример.xlsx (67.74 КБ)

МатросНаЗебре

Пользователь

Сообщений: 6499 Регистрация: 05.02.2014

13.01.2022 17:29:48

Код

Option Explicit

Sub FlatActiveSheet()
    FlatSheet ActiveSheet
End Sub

Sub FlatSheet(sh As Worksheet)
    sh.Copy
    
    With ActiveSheet
        Dim arr As Variant
        Dim orr As Variant
        arr = .UsedRange
        ReDim orr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
        
        Dim dic As Object
        Set dic = CreateObject("Scripting.Dictionary")
        Dim y As Long
        For y = 1 To UBound(arr, 1)
            If Not dic.Exists(CStr(Trim(arr(y, 4)))) Then
                Set dic.Item(CStr(Trim(arr(y, 4)))) = CreateObject("Scripting.Dictionary")
            End If
            dic.Item(CStr(Trim(arr(y, 4)))).Item(CStr(Trim(arr(y, 3)))) = 0
        Next
        
        Dim u As Long
        Dim x As Integer
        For y = 1 To UBound(arr, 1)
            If dic.Exists(CStr(Trim(arr(y, 4)))) Then
                u = u + 1
                For x = 1 To UBound(arr, 2)
                    orr(u, x) = arr(y, x)
                Next
                orr(u, 3) = Join(dic.Item(CStr(Trim(arr(y, 4)))).Keys(), ",")
                dic.Remove (CStr(Trim(arr(y, 4))))
            End If
        Next
        
        .Cells.ClearContents
        .Cells(1, 1).Resize(UBound(orr, 1), UBound(orr, 2)).Value = orr
    End With
End Sub

Вариант названия темы
Удаление дубликатов в одном столбце, сбор данных из другого столбца через запятую.

Изменено: МатросНаЗебре - 13.01.2022 17:36:09

mr.Stone Пользователь Сообщений: 19 Регистрация: 26.03.2014	#3 14.01.2022 12:08:59 , спасибо огромное!