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

Вход

Регистрация

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

 

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

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Макрос для суммирования значений по условию (Макросы/Sub)
Макрос для суммирования значений по условию
mishura08 Дата: Четверг, 24.08.2023, 10:59 | Сообщение № 1
Группа: Проверенные
Ранг: Участник
Сообщений: 65
Репутация: 0 ±
Замечаний: 40% ±

2021
Здравствуйте, подскажите пожалуйста как изменить данный макрос чтоб он суммировал дублирующие значения перед тем как заносить их в отдельный лист.
[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"
    
    lastRow = mainWs.Cells(mainWs.Rows.Count, "A").End(xlUp).Row
    
    ' Заполнение словаря и суммирование данных
    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]

Пример как хотелось бы чтоб это работало приложил в файле.
К сообщению приложен файл: help_pls.xlsm (11.7 Kb)
 
Ответить
СообщениеЗдравствуйте, подскажите пожалуйста как изменить данный макрос чтоб он суммировал дублирующие значения перед тем как заносить их в отдельный лист.
[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"
    
    lastRow = mainWs.Cells(mainWs.Rows.Count, "A").End(xlUp).Row
    
    ' Заполнение словаря и суммирование данных
    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
Дата добавления - 24.08.2023 в 10:59
Oh_Nick Дата: Четверг, 24.08.2023, 15:44 | Сообщение № 2
Группа: Проверенные
Ранг: Обитатель
Сообщений: 445
Репутация: 8 ±
Замечаний: 20% ±

Excel 2019
mishura08, как я понял, что нужно, чтобы похожие значения перенеслись в колонках А и B?
К сообщению приложен файл: 7354557.xlsm (22.2 Kb)
 
Ответить
Сообщениеmishura08, как я понял, что нужно, чтобы похожие значения перенеслись в колонках А и B?

Автор - Oh_Nick
Дата добавления - 24.08.2023 в 15:44
mishura08 Дата: Пятница, 25.08.2023, 06:13 | Сообщение № 3
Группа: Проверенные
Ранг: Участник
Сообщений: 65
Репутация: 0 ±
Замечаний: 40% ±

2021
Опишу подробнее, понял, что недостаточно информации дал.
Получается на данный момент скрипт этот может находить дубли по признаку столбцов: "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
Дата добавления - 25.08.2023 в 06:13
mishura08 Дата: Пятница, 25.08.2023, 06:18 | Сообщение № 4
Группа: Проверенные
Ранг: Участник
Сообщений: 65
Репутация: 0 ±
Замечаний: 40% ±

2021
Oh_Nick, как описал выше, похожие значения должны быть найдены по совпадению столбцов "F" и "I"


Сообщение отредактировал mishura08 - Пятница, 25.08.2023, 06:19
 
Ответить
СообщениеOh_Nick, как описал выше, похожие значения должны быть найдены по совпадению столбцов "F" и "I"

Автор - mishura08
Дата добавления - 25.08.2023 в 06:18
mishura08 Дата: Пятница, 25.08.2023, 08:01 | Сообщение № 5
Группа: Проверенные
Ранг: Участник
Сообщений: 65
Репутация: 0 ±
Замечаний: 40% ±

2021
Вот что мне нужно было примерно, но теперь, почему-то куда-то теряется столбец А по итогу:
[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
Дата добавления - 25.08.2023 в 08:01
MikeVol Дата: Пятница, 25.08.2023, 11:19 | Сообщение № 6
Группа: Проверенные
Ранг: Обитатель
Сообщений: 315
Репутация: 61 ±
Замечаний: 0% ±

Excel LTSC 2021 EN
mishura08, Здравствуйте. Вот в этой строке кода теряеться
столбец А

[vba]
Код
newSheet.Cells(newRow, rng.Column - 1).Value = rng.Value
[/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]


Ученик.

Сообщение отредактировал MikeVol - Пятница, 25.08.2023, 14:45
 
Ответить
Сообщениеmishura08, Здравствуйте. Вот в этой строке кода теряеться
столбец А

[vba]
Код
newSheet.Cells(newRow, rng.Column - 1).Value = rng.Value
[/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]

Автор - MikeVol
Дата добавления - 25.08.2023 в 11:19
mishura08 Дата: Пятница, 25.08.2023, 14:22 | Сообщение № 7
Группа: Проверенные
Ранг: Участник
Сообщений: 65
Репутация: 0 ±
Замечаний: 40% ±

2021
MikeVol, Благодарю!
 
Ответить
СообщениеMikeVol, Благодарю!

Автор - mishura08
Дата добавления - 25.08.2023 в 14:22
MikeVol Дата: Пятница, 25.08.2023, 14:46 | Сообщение № 8
Группа: Проверенные
Ранг: Обитатель
Сообщений: 315
Репутация: 61 ±
Замечаний: 0% ±

Excel LTSC 2021 EN
mishura08, Я заменил код выше.


Ученик.
 
Ответить
Сообщениеmishura08, Я заменил код выше.

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

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