Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Макрос для удаления дубликатов и суммирования значений - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Макрос для удаления дубликатов и суммирования значений (Макросы/Sub)
Макрос для удаления дубликатов и суммирования значений
zhannasemenovaivk Дата: Суббота, 06.05.2023, 10:12 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 3
Репутация: 0 ±
Замечаний: 20% ±

Добрый день.
Помогите, пожалуйста, разобраться с макросом или возможно уже была такая тема на форуме, но я не нашла.
По задаче - необходимо прописать макрос для удаления дублей в сцепке "токен+домен", просуммировать значения по столбцу "показы", а из столбца "тип трафика" вытянуть первое соответствующее значение, то есть, если в таблице встречаются строки с одинаковыми значения по столбцам "токен" и "домен", то дубли необходимо удалить и оставить одну строку, а количество показов по всем этим дублям просуммировать в оставшуюся строку. Тип трафика может отличаться в этих дублях, поэтому тут вытягивается первое значения по какому-то из дублей. Результат необходимо выводить на исходных данных, т.е. заменить их новыми данными. Пример подсчетов во вложении.
Сейчас эта задача решается формулами или записанным макросом, но данная история работает только на небольших файлах, на файлах объемом более 100к (иногда и до 1млн доходит) строк все это происходит очень долго и может занять около 2-х часов (чем больше строк, тем дольше все это считается). Возможно есть какой-то оптимизированный макрос, который ускорит весь этот процесс. Буду очень благодарна за помощь, т.к. сама пока разобраться не могу.
К сообщению приложен файл: vygruzka_33312.xlsx (17.0 Kb)
 
Ответить
СообщениеДобрый день.
Помогите, пожалуйста, разобраться с макросом или возможно уже была такая тема на форуме, но я не нашла.
По задаче - необходимо прописать макрос для удаления дублей в сцепке "токен+домен", просуммировать значения по столбцу "показы", а из столбца "тип трафика" вытянуть первое соответствующее значение, то есть, если в таблице встречаются строки с одинаковыми значения по столбцам "токен" и "домен", то дубли необходимо удалить и оставить одну строку, а количество показов по всем этим дублям просуммировать в оставшуюся строку. Тип трафика может отличаться в этих дублях, поэтому тут вытягивается первое значения по какому-то из дублей. Результат необходимо выводить на исходных данных, т.е. заменить их новыми данными. Пример подсчетов во вложении.
Сейчас эта задача решается формулами или записанным макросом, но данная история работает только на небольших файлах, на файлах объемом более 100к (иногда и до 1млн доходит) строк все это происходит очень долго и может занять около 2-х часов (чем больше строк, тем дольше все это считается). Возможно есть какой-то оптимизированный макрос, который ускорит весь этот процесс. Буду очень благодарна за помощь, т.к. сама пока разобраться не могу.

Автор - zhannasemenovaivk
Дата добавления - 06.05.2023 в 10:12
cmivadwot Дата: Суббота, 06.05.2023, 18:31 | Сообщение № 2
Группа: Проверенные
Ранг: Обитатель
Сообщений: 439
Репутация: 86 ±
Замечаний: 0% ±

365
zhannasemenovaivk, Добрый. А сводную таблицу не пробовали? или это получится не совсем то? Пробовал.. продублировал значения до 500 к строк (9 мб получился файл, не приложить), вроде как быстро обрабатывает.
К сообщению приложен файл: 5785969.xlsx (22.8 Kb)


Сообщение отредактировал cmivadwot - Суббота, 06.05.2023, 18:47
 
Ответить
Сообщениеzhannasemenovaivk, Добрый. А сводную таблицу не пробовали? или это получится не совсем то? Пробовал.. продублировал значения до 500 к строк (9 мб получился файл, не приложить), вроде как быстро обрабатывает.

Автор - cmivadwot
Дата добавления - 06.05.2023 в 18:31
zhannasemenovaivk Дата: Воскресенье, 07.05.2023, 09:27 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 3
Репутация: 0 ±
Замечаний: 20% ±

А сводную таблицу не пробовали?

Пробовала, но это не то, т.к. остаются дубли из-за того, что сводная не выбирает какое-то одно значение по столбцу "Тип трафика", а выбирает оба и, соответственно дубли остаются.
Подсветила один из дублей красным в файле.
К сообщению приложен файл: 4783185.xlsx (23.7 Kb)


Сообщение отредактировал zhannasemenovaivk - Воскресенье, 07.05.2023, 09:28
 
Ответить
Сообщение
А сводную таблицу не пробовали?

Пробовала, но это не то, т.к. остаются дубли из-за того, что сводная не выбирает какое-то одно значение по столбцу "Тип трафика", а выбирает оба и, соответственно дубли остаются.
Подсветила один из дублей красным в файле.

Автор - zhannasemenovaivk
Дата добавления - 07.05.2023 в 09:27
cmivadwot Дата: Воскресенье, 07.05.2023, 11:02 | Сообщение № 4
Группа: Проверенные
Ранг: Обитатель
Сообщений: 439
Репутация: 86 ±
Замечаний: 0% ±

365
Цитата zhannasemenovaivk, 07.05.2023 в 09:27, в сообщении № 3 ()
Подсветила один из дублей красным в файле.

Это не совем дубль. супертинейджеры.рф InApp, супертинейджеры.рф Web. если нет необходимости в информации Web или InApp , то просто убрать этот столбец из сводной
К сообщению приложен файл: bezdubl.xlsx (23.5 Kb)
 
Ответить
Сообщение
Цитата zhannasemenovaivk, 07.05.2023 в 09:27, в сообщении № 3 ()
Подсветила один из дублей красным в файле.

Это не совем дубль. супертинейджеры.рф InApp, супертинейджеры.рф Web. если нет необходимости в информации Web или InApp , то просто убрать этот столбец из сводной

Автор - cmivadwot
Дата добавления - 07.05.2023 в 11:02
i_b_a Дата: Воскресенье, 07.05.2023, 21:19 | Сообщение № 5
Группа: Пользователи
Ранг: Прохожий
Сообщений: 8
Репутация: 0 ±
Замечаний: 0% ±

2019
Если тип трафика не нужен - то можно так на немаках:
[vba]
Код

Sub tt()
Dim a, i&, t$
Dim oDict As Object, kk

a = [a1].CurrentRegion.Value

Set oDict = CreateObject("Scripting.Dictionary"): oDict.comparemode = 1
    For i = 2 To UBound(a)
        t = a(i, 1) & "|" & a(i, 3)
        oDict.Item(t) = oDict.Item(t) + a(i, 4)
    Next

ReDim a(1 To oDict.Count + 1, 1 To 4)
a(1, 1) = "Токен"
a(1, 2) = "неужный Тип трафика"
a(1, 3) = "Домен"
a(1, 4) = "Показы"

  i = 1
    For Each kk In oDict.keys
        i = i + 1
        a(i, 1) = Split(kk, "|")(0)
        a(i, 3) = Split(kk, "|")(1)
        a(i, 4) = oDict.Item(kk)
    Next
        
    With Workbooks.Add(1).Sheets(1)
        .Cells(1).Resize(UBound(a), 4) = a
        .Cells.EntireColumn.AutoFit
    End With
    

End Sub
[/vba]
Если нужен - нужно дописывать ещё один словарь, или в этот массив с коллекцией добавлять...


Игорь
 
Ответить
СообщениеЕсли тип трафика не нужен - то можно так на немаках:
[vba]
Код

Sub tt()
Dim a, i&, t$
Dim oDict As Object, kk

a = [a1].CurrentRegion.Value

Set oDict = CreateObject("Scripting.Dictionary"): oDict.comparemode = 1
    For i = 2 To UBound(a)
        t = a(i, 1) & "|" & a(i, 3)
        oDict.Item(t) = oDict.Item(t) + a(i, 4)
    Next

ReDim a(1 To oDict.Count + 1, 1 To 4)
a(1, 1) = "Токен"
a(1, 2) = "неужный Тип трафика"
a(1, 3) = "Домен"
a(1, 4) = "Показы"

  i = 1
    For Each kk In oDict.keys
        i = i + 1
        a(i, 1) = Split(kk, "|")(0)
        a(i, 3) = Split(kk, "|")(1)
        a(i, 4) = oDict.Item(kk)
    Next
        
    With Workbooks.Add(1).Sheets(1)
        .Cells(1).Resize(UBound(a), 4) = a
        .Cells.EntireColumn.AutoFit
    End With
    

End Sub
[/vba]
Если нужен - нужно дописывать ещё один словарь, или в этот массив с коллекцией добавлять...

Автор - i_b_a
Дата добавления - 07.05.2023 в 21:19
i_b_a Дата: Воскресенье, 07.05.2023, 21:38 | Сообщение № 6
Группа: Пользователи
Ранг: Прохожий
Сообщений: 8
Репутация: 0 ±
Замечаний: 0% ±

2019
С типом трафика, чуть дольше будет работать:
[vba]
Код

Option Explicit

Sub ttt()
Dim a, i&, t$
Dim oDict As Object, oDict2 As Object, kk, el

a = [a1].CurrentRegion.Value

Set oDict = CreateObject("Scripting.Dictionary"): oDict.comparemode = 1
Set oDict2 = CreateObject("Scripting.Dictionary"): oDict2.comparemode = 1

On Error Resume Next
    For i = 2 To UBound(a)
        t = a(i, 1) & "|" & a(i, 3)
        oDict.Item(t) = oDict.Item(t) + a(i, 4)
        If Not oDict2.exists(t) Then oDict2.Add t, New Collection
        oDict2.Item(t).Add a(i, 2), "" & a(i, 2)
    Next
On Error GoTo 0

ReDim a(1 To oDict.Count + 1, 1 To 4)
a(1, 1) = "Токен"
a(1, 2) = "Тип трафика"
a(1, 3) = "Домен"
a(1, 4) = "Показы"

  i = 1
    For Each kk In oDict.keys
        i = i + 1
        a(i, 1) = Split(kk, "|")(0)
        t = ""
        For Each el In oDict2.Item(kk)
        t = t & ", " & el
        Next
        a(i, 2) = Mid(t, 3)
        a(i, 3) = Split(kk, "|")(1)
        a(i, 4) = oDict.Item(kk)
    Next
        
    With Workbooks.Add(1).Sheets(1)
        .Cells(1).Resize(UBound(a), 4) = a
        .Cells.EntireColumn.AutoFit
    End With
    
End Sub
[/vba]


Игорь
 
Ответить
СообщениеС типом трафика, чуть дольше будет работать:
[vba]
Код

Option Explicit

Sub ttt()
Dim a, i&, t$
Dim oDict As Object, oDict2 As Object, kk, el

a = [a1].CurrentRegion.Value

Set oDict = CreateObject("Scripting.Dictionary"): oDict.comparemode = 1
Set oDict2 = CreateObject("Scripting.Dictionary"): oDict2.comparemode = 1

On Error Resume Next
    For i = 2 To UBound(a)
        t = a(i, 1) & "|" & a(i, 3)
        oDict.Item(t) = oDict.Item(t) + a(i, 4)
        If Not oDict2.exists(t) Then oDict2.Add t, New Collection
        oDict2.Item(t).Add a(i, 2), "" & a(i, 2)
    Next
On Error GoTo 0

ReDim a(1 To oDict.Count + 1, 1 To 4)
a(1, 1) = "Токен"
a(1, 2) = "Тип трафика"
a(1, 3) = "Домен"
a(1, 4) = "Показы"

  i = 1
    For Each kk In oDict.keys
        i = i + 1
        a(i, 1) = Split(kk, "|")(0)
        t = ""
        For Each el In oDict2.Item(kk)
        t = t & ", " & el
        Next
        a(i, 2) = Mid(t, 3)
        a(i, 3) = Split(kk, "|")(1)
        a(i, 4) = oDict.Item(kk)
    Next
        
    With Workbooks.Add(1).Sheets(1)
        .Cells(1).Resize(UBound(a), 4) = a
        .Cells.EntireColumn.AutoFit
    End With
    
End Sub
[/vba]

Автор - i_b_a
Дата добавления - 07.05.2023 в 21:38
zhannasemenovaivk Дата: Понедельник, 08.05.2023, 08:58 | Сообщение № 7
Группа: Пользователи
Ранг: Прохожий
Сообщений: 3
Репутация: 0 ±
Замечаний: 20% ±

Добрый день. Большое спасибо за скрипт, все работает и куда быстрее чем было до этого. Не могли бы вы прописать комментарии к скрипту, я только изучаю макросы и хотелось бы понимать, что и где происходит. Если не сложно.


Сообщение отредактировал Serge_007 - Вторник, 09.05.2023, 10:03
 
Ответить
СообщениеДобрый день. Большое спасибо за скрипт, все работает и куда быстрее чем было до этого. Не могли бы вы прописать комментарии к скрипту, я только изучаю макросы и хотелось бы понимать, что и где происходит. Если не сложно.

Автор - zhannasemenovaivk
Дата добавления - 08.05.2023 в 08:58
i_b_a Дата: Понедельник, 08.05.2023, 22:06 | Сообщение № 8
Группа: Пользователи
Ранг: Прохожий
Сообщений: 8
Репутация: 0 ±
Замечаний: 0% ±

2019
С комментариями.
Можете в конце ещё дописать например красивое форматирование шапки.
[vba]
Код

Option Explicit

Sub ttt()
Dim a, i&, t$
Dim oDict As Object, oDict2 As Object, kk, el

a = [a1].CurrentRegion.Value ' берём в массив данные

'создаём два словаря, у ключей не будем учитывать строчные или прописные (это может и лишнее)
Set oDict = CreateObject("Scripting.Dictionary"): oDict.comparemode = 1
Set oDict2 = CreateObject("Scripting.Dictionary"): oDict2.comparemode = 1

On Error Resume Next 'отключение ошибок при повторах в наполнения коллекции
    For i = 2 To UBound(a) 'цикл по массиву
        t = a(i, 1) & "|" & a(i, 3) 'временная переменная - это будет ключ словаря. Создаю чтобы далее по коду сэкономить символы, да и быстрее - не лезем лишний раз в массив
        oDict.Item(t) = oDict.Item(t) + a(i, 4) 'в первый словарь каждому ключу собираем суммы из массива столбец 4
        If Not oDict2.exists(t) Then oDict2.Add t, New Collection 'если во втором словаре ещё нет ключа - добавляем с пустой коллекцией
        oDict2.Item(t).Add a(i, 2), "" & a(i, 2) ' в коллекцию ключа добавляем значение второго столбца массива (Тип трафика) - будут только уникальные, т.к. коллекция с ключём (строкового типа)
    Next
On Error GoTo 0 'включение ошибок

ReDim a(1 To oDict.Count + 1, 1 To 4) 'создаём массив для результатов работы теперь уже известного размера

i = 1
'пишем шапки, хотя это можно сделать и в конце уже на листе одним действием, но так понятнее
a(i, 1) = "Токен"
a(i, 2) = "Тип трафика"
a(i, 3) = "Домен"
a(i, 4) = "Показы"

'перебор ключей первого словаря (в обоих ключи одинаковы)
    For Each kk In oDict.keys
        i = i + 1
        a(i, 1) = Split(kk, "|")(0) 'пишем токен (из ключа, до разделителя)
        t = ""
        For Each el In oDict2.Item(kk) 'перебором коллекции ключа собираем строку "Тип трафика"
        t = t & ", " & el
        Next
        a(i, 2) = Mid(t, 3) 'пишем собранную строку без первых ", "
        a(i, 3) = Split(kk, "|")(1) 'пишем домен (из ключа, после разделителя)
        a(i, 4) = oDict.Item(kk) 'пишем собранную сумму
    Next
        
    With Workbooks.Add(1).Sheets(1) 'создание новой книги с одним листом
        .Cells(1).Resize(UBound(a), 4) = a ' выгрузка заполненного массива
        .Cells.EntireColumn.AutoFit 'задаём автоширину столбцов
    End With
    
End Sub

[/vba]


Игорь

Сообщение отредактировал i_b_a - Понедельник, 08.05.2023, 22:08
 
Ответить
СообщениеС комментариями.
Можете в конце ещё дописать например красивое форматирование шапки.
[vba]
Код

Option Explicit

Sub ttt()
Dim a, i&, t$
Dim oDict As Object, oDict2 As Object, kk, el

a = [a1].CurrentRegion.Value ' берём в массив данные

'создаём два словаря, у ключей не будем учитывать строчные или прописные (это может и лишнее)
Set oDict = CreateObject("Scripting.Dictionary"): oDict.comparemode = 1
Set oDict2 = CreateObject("Scripting.Dictionary"): oDict2.comparemode = 1

On Error Resume Next 'отключение ошибок при повторах в наполнения коллекции
    For i = 2 To UBound(a) 'цикл по массиву
        t = a(i, 1) & "|" & a(i, 3) 'временная переменная - это будет ключ словаря. Создаю чтобы далее по коду сэкономить символы, да и быстрее - не лезем лишний раз в массив
        oDict.Item(t) = oDict.Item(t) + a(i, 4) 'в первый словарь каждому ключу собираем суммы из массива столбец 4
        If Not oDict2.exists(t) Then oDict2.Add t, New Collection 'если во втором словаре ещё нет ключа - добавляем с пустой коллекцией
        oDict2.Item(t).Add a(i, 2), "" & a(i, 2) ' в коллекцию ключа добавляем значение второго столбца массива (Тип трафика) - будут только уникальные, т.к. коллекция с ключём (строкового типа)
    Next
On Error GoTo 0 'включение ошибок

ReDim a(1 To oDict.Count + 1, 1 To 4) 'создаём массив для результатов работы теперь уже известного размера

i = 1
'пишем шапки, хотя это можно сделать и в конце уже на листе одним действием, но так понятнее
a(i, 1) = "Токен"
a(i, 2) = "Тип трафика"
a(i, 3) = "Домен"
a(i, 4) = "Показы"

'перебор ключей первого словаря (в обоих ключи одинаковы)
    For Each kk In oDict.keys
        i = i + 1
        a(i, 1) = Split(kk, "|")(0) 'пишем токен (из ключа, до разделителя)
        t = ""
        For Each el In oDict2.Item(kk) 'перебором коллекции ключа собираем строку "Тип трафика"
        t = t & ", " & el
        Next
        a(i, 2) = Mid(t, 3) 'пишем собранную строку без первых ", "
        a(i, 3) = Split(kk, "|")(1) 'пишем домен (из ключа, после разделителя)
        a(i, 4) = oDict.Item(kk) 'пишем собранную сумму
    Next
        
    With Workbooks.Add(1).Sheets(1) 'создание новой книги с одним листом
        .Cells(1).Resize(UBound(a), 4) = a ' выгрузка заполненного массива
        .Cells.EntireColumn.AutoFit 'задаём автоширину столбцов
    End With
    
End Sub

[/vba]

Автор - i_b_a
Дата добавления - 08.05.2023 в 22:06
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Макрос для удаления дубликатов и суммирования значений (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!