Добавление строки и суммирование одинаковых данных в ней, реально ли реализовать через макрос?

[Just_07]

Добавление строки и суммирование одинаковых данных в ней, реально ли реализовать через макрос? Прикрепляю пример.

[kuklp]

Sub www()
    Dim i%, n&, c&, a, k&
    Worksheets("Лист2").UsedRange.ClearContents
    a = Worksheets(1).Range("d3:j12")
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a)
            If a(i, 6) <> "" Then
                If .exists(a(i, 6)) Then
                    n = .Item((a(i, 6)))
                    For c = 1 To UBound(a, 2)
                        If IsNumeric(a(i, c)) Then a(n, c) = a(n, c) + a(i, c)
                    Next
                Else
                    k = k + 1: .Item((a(i, 6))) = k
                    For c = 1 To UBound(a, 2)
                        a(k, c) = a(i, c)
                    Next
                End If
            End If
        Next
    End With
    Worksheets("Лист2").[a3].Resize(k, 7) = a: Worksheets("Лист2").Activate
End Sub

[Just_07]

Спасибо что откликнулись, но это не совсем то что я хотел. Должно быть как в примере ниже т.е. сравнивание по I столбцу и по J столбцу, если I в предыдущей строке равно I в сравниваемой, а также возможно в строке ниже-последующей, то вставлять строку под последним одинаковым I и суммировать значения только из D E F G, при этом должно выполняться условие что и данные в столбце J равны между собой. Т.е. если в столбце I между собой равны 3 строки, а в столбце J строки которые соответствуют I между собой только 2 строки, суммируем только 2 строки вставляя строку под одинаковыми J. Прикрепляю пример еще раз смотрите, может этот более понятен будет.

В примере заменил числа которые будут разными на "1" так лучше виден результат который нужно получить. Обязательное условие равенство I и I(последующая строка), а соответствующие им J и J(последующая строка) НЕ между собой, а в своих столбцах.
Заранее спасибо всем кто помогает или пытается помочь.

[Just_07]

Так называемый поиск и суммирование по двум критериям с добавление строки.

[kuklp]

А смекалку включить? Совсем же не сложно, хоть по десяти полям сравнивай:

Sub www()
    Dim i%, n&, c&, a, k&
    Worksheets("Лист2").UsedRange.ClearContents
    a = Worksheets(1).Range("d3:j12")
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a)
            If a(i, 6) <> "" Then
                If .exists(a(i, 6) & a(i, 7)) Then
                    n = .Item(a(i, 6) & a(i, 7))
                    For c = 1 To 4
                        If IsNumeric(a(i, c)) Then a(n, c) = a(n, c) + a(i, c)
                    Next
                Else
                    k = k + 1: .Item(a(i, 6) & a(i, 7)) = k
                    For c = 1 To UBound(a, 2)
                        a(k, c) = a(i, c)
                    Next
                End If
            End If
        Next
    End With
    Worksheets("Лист2").[a3].Resize(k, 7) = a: Worksheets("Лист2").Activate
End Sub

[Just_07]

О! Вот теперь работает! Огромное спасибо, но оно вставляет полученный резльтат на отдельный лист. А так что бы строку добавляло и помечало красным в массив который анализируется нереально?

[Just_07]

Ну или на второй лист переносило, сравневыемые данные а суммы помечало красным и вставляло под каждыми не уинкальными или просто помечало красным если значения уникальны, как в "Пример_2" ниже.

[Just_07]

Народ помогите! Нужно срочно.

[Hugo121]

"Промежуточные итоги":

[Just_07]

Ух! И даже без макроса, отлично, век живи, век учись!!!! Огромное вам спасибо! А также не меньшее спасибо kuklp за помошь!