Здравствуйте, подскажите пожалуйста как изменить данный макрос чтоб он суммировал дублирующие значения перед тем как заносить их в отдельный лист. [vba]
Код
Sub MergeAndSumDuplicates() Dim mainWs As Worksheet Dim newWs As Worksheet Dim lastRow As Long Dim newRow As Long Dim dict As Object Dim key As Variant Dim i As Long, j As Long Dim valuesArray() As Variant
' Создаем словарь для хранения данных Set dict = CreateObject("Scripting.Dictionary")
' Указываем основной и новый листы Set mainWs = ThisWorkbook.Sheets("Product") ' Замените на имя вашего листа с данными Set newWs = ThisWorkbook.Sheets.Add(After:=mainWs) newWs.Name = "Unique"
' Заполнение словаря и суммирование данных For i = 2 To lastRow searchTerm = mainWs.Cells(i, "I").Value adGroup = mainWs.Cells(i, "F").Value If Not dict.Exists(searchTerm) Then ReDim valuesArray(1 To 1, 1 To 24) For j = 1 To 24 valuesArray(1, j) = mainWs.Cells(i, j).Value Next j dict(searchTerm) = valuesArray Else For j = 10 To 24 ' Начинаем с 10 столбца, чтобы не изменять столбцы A:I If j <> 11 And j <> 12 And j <> 13 And j <> 15 And j <> 16 And j <> 17 And j <> 18 And j <> 19 And j <> 20 Then ' Пропускаем столбцы, которые не надо суммировать dict(searchTerm)(1, j) = dict(searchTerm)(1, j) + mainWs.Cells(i, j).Value End If Next j End If Next i
' Запись заголовков столбцов на новый лист newWs.Cells(1, 1).Resize(1, 24).Value = mainWs.Cells(1, 1).Resize(1, 24).Value
' Запись данных на новый лист newRow = 2
For Each key In dict.Keys newWs.Cells(newRow, 1).Resize(1, 24).Value = dict(key) newRow = newRow + 1 Next key
' Освобождаем память, выделенную для словаря Set dict = Nothing
' Удаляем дубликаты на основном листе mainWs.Range("A1:X" & lastRow).RemoveDuplicates Columns:=Array(9, 6), Header:=xlYes End Sub
[/vba]
Пример как хотелось бы чтоб это работало приложил в файле.
Здравствуйте, подскажите пожалуйста как изменить данный макрос чтоб он суммировал дублирующие значения перед тем как заносить их в отдельный лист. [vba]
Код
Sub MergeAndSumDuplicates() Dim mainWs As Worksheet Dim newWs As Worksheet Dim lastRow As Long Dim newRow As Long Dim dict As Object Dim key As Variant Dim i As Long, j As Long Dim valuesArray() As Variant
' Создаем словарь для хранения данных Set dict = CreateObject("Scripting.Dictionary")
' Указываем основной и новый листы Set mainWs = ThisWorkbook.Sheets("Product") ' Замените на имя вашего листа с данными Set newWs = ThisWorkbook.Sheets.Add(After:=mainWs) newWs.Name = "Unique"
' Заполнение словаря и суммирование данных For i = 2 To lastRow searchTerm = mainWs.Cells(i, "I").Value adGroup = mainWs.Cells(i, "F").Value If Not dict.Exists(searchTerm) Then ReDim valuesArray(1 To 1, 1 To 24) For j = 1 To 24 valuesArray(1, j) = mainWs.Cells(i, j).Value Next j dict(searchTerm) = valuesArray Else For j = 10 To 24 ' Начинаем с 10 столбца, чтобы не изменять столбцы A:I If j <> 11 And j <> 12 And j <> 13 And j <> 15 And j <> 16 And j <> 17 And j <> 18 And j <> 19 And j <> 20 Then ' Пропускаем столбцы, которые не надо суммировать dict(searchTerm)(1, j) = dict(searchTerm)(1, j) + mainWs.Cells(i, j).Value End If Next j End If Next i
' Запись заголовков столбцов на новый лист newWs.Cells(1, 1).Resize(1, 24).Value = mainWs.Cells(1, 1).Resize(1, 24).Value
' Запись данных на новый лист newRow = 2
For Each key In dict.Keys newWs.Cells(newRow, 1).Resize(1, 24).Value = dict(key) newRow = newRow + 1 Next key
' Освобождаем память, выделенную для словаря Set dict = Nothing
' Удаляем дубликаты на основном листе mainWs.Range("A1:X" & lastRow).RemoveDuplicates Columns:=Array(9, 6), Header:=xlYes End Sub
[/vba]
Пример как хотелось бы чтоб это работало приложил в файле.mishura08
Опишу подробнее, понял, что недостаточно информации дал. Получается на данный момент скрипт этот может находить дубли по признаку столбцов: "F" and "I" (Ad Group Name и Customer Search Term). Но он не суммирует статистику, столбцы: Impressions, Clicks, Spend, 7 Day Total Sales, 7 Day Total Orders, 7 Day Total Units, 7 Day Advertised SKU Units, 7 Day Other SKU Units, 7 Day Advertised SKU Sales, 7 Day Other SKU Sales Именно эти столбцы: ‘J’, ‘K’, ‘N’, ‘O’, ‘R’, ‘S’, ‘U’, ‘V’, ‘W’, ‘X’. Он просто берет статистику первого попавшегося дубля и подставляет ее. А это понятно что никуда не годится.. Есть варианты у кого-нибудь как сделать?
Опишу подробнее, понял, что недостаточно информации дал. Получается на данный момент скрипт этот может находить дубли по признаку столбцов: "F" and "I" (Ad Group Name и Customer Search Term). Но он не суммирует статистику, столбцы: Impressions, Clicks, Spend, 7 Day Total Sales, 7 Day Total Orders, 7 Day Total Units, 7 Day Advertised SKU Units, 7 Day Other SKU Units, 7 Day Advertised SKU Sales, 7 Day Other SKU Sales Именно эти столбцы: ‘J’, ‘K’, ‘N’, ‘O’, ‘R’, ‘S’, ‘U’, ‘V’, ‘W’, ‘X’. Он просто берет статистику первого попавшегося дубля и подставляет ее. А это понятно что никуда не годится.. Есть варианты у кого-нибудь как сделать?mishura08
Вот что мне нужно было примерно, но теперь, почему-то куда-то теряется столбец А по итогу: [vba]
Код
Sub RemoveDuplicatesAndSummarize() Dim sourceSheet As Worksheet Dim newSheet As Worksheet Dim lastRow As Long Dim newRow As Long Dim dict As Object Dim dictKey As Variant Dim rng As Range Dim i As Long
' Создаем новый лист для результатов Set newSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) newSheet.Name = "NoDuplicates"
' Указываем исходный лист Set sourceSheet = ThisWorkbook.Sheets("Исходный_лист") ' Замените на имя вашего листа
' Определяем последнюю заполненную строку в столбце A исходного листа lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row
' Инициализируем словарь для хранения сумм статистики по ключу Set dict = CreateObject("Scripting.Dictionary")
' Проходимся по каждой строке исходного листа For i = 2 To lastRow ' Предполагаем, что заголовки находятся в строке 1 ' Формируем ключ на основе значений в столбцах F и I dictKey = sourceSheet.Cells(i, "F").Value & "|" & sourceSheet.Cells(i, "I").Value
' Проверяем, есть ли ключ уже в словаре If dict.Exists(dictKey) Then ' Если ключ уже есть, то суммируем статистику For Each rng In newSheet.Range("J1:X1") newSheet.Cells(dict(dictKey), rng.Column).Value = newSheet.Cells(dict(dictKey), rng.Column).Value + sourceSheet.Cells(i, rng.Column).Value Next rng Else ' Если ключа еще нет, то добавляем его в словарь и запоминаем строку для статистики newRow = newRow + 1 dict(dictKey) = newRow newSheet.Cells(newRow, "A").Value = sourceSheet.Cells(i, "A").Value newSheet.Cells(newRow, "B").Value = sourceSheet.Cells(i, "B").Value For Each rng In sourceSheet.Range("C" & i & ":I" & i) newSheet.Cells(newRow, rng.Column - 1).Value = rng.Value Next rng For Each rng In newSheet.Range("J1:X1") newSheet.Cells(newRow, rng.Column).Value = sourceSheet.Cells(i, rng.Column).Value Next rng End If Next i
' Вставляем заголовки в новый лист newSheet.Range("A1").Resize(1, 24).Value = sourceSheet.Range("A1:X1").Value End Sub
[/vba]
В остальном работает как и хотелось.. кроме конечно того что исчезает куда-то столбец А..
Вот что мне нужно было примерно, но теперь, почему-то куда-то теряется столбец А по итогу: [vba]
Код
Sub RemoveDuplicatesAndSummarize() Dim sourceSheet As Worksheet Dim newSheet As Worksheet Dim lastRow As Long Dim newRow As Long Dim dict As Object Dim dictKey As Variant Dim rng As Range Dim i As Long
' Создаем новый лист для результатов Set newSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) newSheet.Name = "NoDuplicates"
' Указываем исходный лист Set sourceSheet = ThisWorkbook.Sheets("Исходный_лист") ' Замените на имя вашего листа
' Определяем последнюю заполненную строку в столбце A исходного листа lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row
' Инициализируем словарь для хранения сумм статистики по ключу Set dict = CreateObject("Scripting.Dictionary")
' Проходимся по каждой строке исходного листа For i = 2 To lastRow ' Предполагаем, что заголовки находятся в строке 1 ' Формируем ключ на основе значений в столбцах F и I dictKey = sourceSheet.Cells(i, "F").Value & "|" & sourceSheet.Cells(i, "I").Value
' Проверяем, есть ли ключ уже в словаре If dict.Exists(dictKey) Then ' Если ключ уже есть, то суммируем статистику For Each rng In newSheet.Range("J1:X1") newSheet.Cells(dict(dictKey), rng.Column).Value = newSheet.Cells(dict(dictKey), rng.Column).Value + sourceSheet.Cells(i, rng.Column).Value Next rng Else ' Если ключа еще нет, то добавляем его в словарь и запоминаем строку для статистики newRow = newRow + 1 dict(dictKey) = newRow newSheet.Cells(newRow, "A").Value = sourceSheet.Cells(i, "A").Value newSheet.Cells(newRow, "B").Value = sourceSheet.Cells(i, "B").Value For Each rng In sourceSheet.Range("C" & i & ":I" & i) newSheet.Cells(newRow, rng.Column - 1).Value = rng.Value Next rng For Each rng In newSheet.Range("J1:X1") newSheet.Cells(newRow, rng.Column).Value = sourceSheet.Cells(i, rng.Column).Value Next rng End If Next i
' Вставляем заголовки в новый лист newSheet.Range("A1").Resize(1, 24).Value = sourceSheet.Range("A1:X1").Value End Sub
[/vba]
В остальном работает как и хотелось.. кроме конечно того что исчезает куда-то столбец А..mishura08
[/vba] Уберите -1 и будет вам счастье! И полностью рабочий код будет таким: [vba]
Код
Option Explicit
Sub RemoveDuplicatesAndSummarize() Dim rng As Range Dim i As Long
' Создаем новый лист для результатов Dim newSheet As Worksheet: Set newSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) newSheet.Name = "NoDuplicates"
' Указываем исходный лист Dim sourceSheet As Worksheet: Set sourceSheet = ThisWorkbook.Sheets("Start")
' Определяем последнюю заполненную строку в столбце A исходного листа Dim lastRow As Long: lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row
' Инициализируем словарь для хранения сумм статистики по ключу Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
' Проходимся по каждой строке исходного листа For i = 2 To lastRow ' Предполагаем, что заголовки находятся в строке 1
' Формируем ключ на основе значений в столбцах F и I Dim dictKey As Variant: dictKey = sourceSheet.Cells(i, "F").Value & "|" & sourceSheet.Cells(i, "I").Value
' Проверяем, есть ли ключ уже в словаре If dict.Exists(dictKey) Then
' Если ключ уже есть, то суммируем статистику из исходного листа For Each rng In sourceSheet.Range("J" & i & ":X" & i) newSheet.Cells(dict(dictKey), rng.Column).Value = newSheet.Cells(dict(dictKey), rng.Column).Value + rng.Value Next rng
Else
' Если ключа еще нет, то добавляем его в словарь и запоминаем строку для статистики Dim newRow As Long: newRow = newRow + 1 dict(dictKey) = newRow newSheet.Cells(newRow, "A").Value = sourceSheet.Cells(i, "A").Value newSheet.Cells(newRow, "B").Value = sourceSheet.Cells(i, "B").Value
For Each rng In sourceSheet.Range("C" & i & ":I" & i) newSheet.Cells(newRow, rng.Column).Value = rng.Value Next rng
For Each rng In sourceSheet.Range("J" & i & ":X" & i) newSheet.Cells(newRow, rng.Column).Value = rng.Value Next rng
End If
Next i
' Вставляем заголовки в новый лист newSheet.Rows("1:1").Insert Shift:=xlDown newSheet.Range("A1").Resize(1, 24).Value = sourceSheet.Range("A1:X1").Value End Sub
[/vba]
mishura08, Здравствуйте. Вот в этой строке кода теряеться
[/vba] Уберите -1 и будет вам счастье! И полностью рабочий код будет таким: [vba]
Код
Option Explicit
Sub RemoveDuplicatesAndSummarize() Dim rng As Range Dim i As Long
' Создаем новый лист для результатов Dim newSheet As Worksheet: Set newSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) newSheet.Name = "NoDuplicates"
' Указываем исходный лист Dim sourceSheet As Worksheet: Set sourceSheet = ThisWorkbook.Sheets("Start")
' Определяем последнюю заполненную строку в столбце A исходного листа Dim lastRow As Long: lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row
' Инициализируем словарь для хранения сумм статистики по ключу Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
' Проходимся по каждой строке исходного листа For i = 2 To lastRow ' Предполагаем, что заголовки находятся в строке 1
' Формируем ключ на основе значений в столбцах F и I Dim dictKey As Variant: dictKey = sourceSheet.Cells(i, "F").Value & "|" & sourceSheet.Cells(i, "I").Value
' Проверяем, есть ли ключ уже в словаре If dict.Exists(dictKey) Then
' Если ключ уже есть, то суммируем статистику из исходного листа For Each rng In sourceSheet.Range("J" & i & ":X" & i) newSheet.Cells(dict(dictKey), rng.Column).Value = newSheet.Cells(dict(dictKey), rng.Column).Value + rng.Value Next rng
Else
' Если ключа еще нет, то добавляем его в словарь и запоминаем строку для статистики Dim newRow As Long: newRow = newRow + 1 dict(dictKey) = newRow newSheet.Cells(newRow, "A").Value = sourceSheet.Cells(i, "A").Value newSheet.Cells(newRow, "B").Value = sourceSheet.Cells(i, "B").Value
For Each rng In sourceSheet.Range("C" & i & ":I" & i) newSheet.Cells(newRow, rng.Column).Value = rng.Value Next rng
For Each rng In sourceSheet.Range("J" & i & ":X" & i) newSheet.Cells(newRow, rng.Column).Value = rng.Value Next rng
End If
Next i
' Вставляем заголовки в новый лист newSheet.Rows("1:1").Insert Shift:=xlDown newSheet.Range("A1").Resize(1, 24).Value = sourceSheet.Range("A1:X1").Value End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
