VBA Excel макрос Создание макроса для сравнения значений ячеек, а затем вставить строку между наборами

Question

Я верю, что на фотографиях все покажет.

Первый - это источник, в который макрос должен вставить строку между наборами и вычислить сумму множеств. Один набор строится по столбцу "I"/ Тема. Например, набор "Магазин Z01"

Это должно быть результатом:

Я очень старался, но безуспешно ... Любая помощь будет принята с благодарностью, даже в решении части всей задачи.

Answer 1

Sub FindSets_and_Sum()
'
    ScreenUpdating = False
    Columns("A:j").Sort key1:=Range("i:i"), order1:=xlAscending, Header:=xlYes
    ActiveSheet.Range("i2").Select
    FirstItem = ActiveCell.Value
    SecondItem = ActiveCell.Offset(1, 0).Value
    Offsetcount = 1
    Rowoffset = 0
    myNum = 100
    'myNum = (Range("A" & Rows.Count).End(xlUp).Row)
    Do While myNum > 0
        If FirstItem = SecondItem Then
            Offsetcount = Offsetcount + 1
            Rowoffset = Rowoffset + 1
            SecondItem = ActiveCell.Offset(Offsetcount, 0).Value
        Else
            Set myActiveCell = ActiveCell
            Set MyActiveCell_01 = ActiveCell
            MyActiveRow_01 = ActiveCell.Row
            MyActiveColumn_01 = ActiveCell.Column
            Set myActiveWorksheet = ActiveSheet
            Set myActiveWorkbook = ActiveWorkbook
            Dim Report As Worksheet 'Set up your new worksheet variable.
            Set Report = Excel.ActiveSheet 'Assign the active sheet to the variable.
            mySum = WorksheetFunction.Sum(Range("j" & MyActiveRow_01 & ":j" & MyActiveRow_01 + Rowoffset))
            Report.Cells(MyActiveRow_01, MyActiveColumn_01 + 2).Value = mySum 'Add the function.
            mySum = 0
            ActiveCell.Offset(Offsetcount, 0).Rows("1:1").EntireRow.Select
            Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            myActiveWorkbook.Activate
            myActiveWorksheet.Activate
            myActiveCell.Activate
            Set MyActiveCell02 = ActiveCell
            Set MyActiveCell_02 = ActiveCell
            MyActiveRow_02 = ActiveCell.Row
            MyActiveColumn_02 = ActiveCell.Column

            ActiveCell.Offset(Offsetcount + 1, 0).Select
            If ActiveCell.Value = "" Then
                myNum = 0
            End If

            FirstItem = ActiveCell.Value
            SecondItem = ActiveCell.Offset(1, 0).Value
            Offsetcount = 1
            myNum = myNum - 1
            Rowoffset = 0
        End If
    Loop
    ScreenUpdating = True
End Sub