vba excel macro Criando uma macro para comparar os valores das células e, em seguida, inserir uma linha entre os conjuntos

Question

Eu acredito que as imagens mostrarão tudo.

A primeira é a fonte em que a macro deve inserir uma linha entre conjuntos e calcular a soma de conjuntos. Um conjunto é construído pela coluna "I" / Assunto. Por exemplo, o conjunto "Store Z01"

Essedeveseroresultado:

Eu tentei com afinco, mas não obtive sucesso ... Qualquer ajuda será muito apreciada, mesmo na resolução de parte de toda a tarefa.

    

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