Sub Macro()
    Dim Wb As Workbook, Sh As Worksheet, A()
    Set Sh = ActiveSheet
    Set Wb = Sh.Parent
    LastRow = Sh.Cells(Sh.Rows.Count, "C").End(xlUp).Row
    Set List = CreateObject("scripting.dictionary")
    dx = Sh.Range("C1:G" & LastRow)
    For n = 2 To UBound(dx)
        Key = Year(CDate(dx(n, 5)))
        Total = Val(Replace(dx(n, 1), ",", "."))
        reg = 0
        If dx(n, 4) = "Зарегистрирован" Then
            reg = Total
        End If
        If List.Exists(Key) Then
            A = List.Item(Key)
            A(1) = A(1) + Total
            A(2) = A(2) + reg
            List.Item(Key) = A
        Else
            List.Item(Key) = Array(Key, Total, reg)
        End If
    Next

    Wb.Worksheets.Add After:=Wb.Worksheets(Wb.Worksheets.Count)
    Set Sh = Wb.Worksheets(Wb.Worksheets.Count)
    Sh.Range("B1").Value = "ВЕСЬ ДОХОД"
    Sh.Range("C1").Value = "АКТ ДОХОД"
    Sh.Range("A1").Value = "ГОД"
    Items = List.Items
    For n = 0 To List.Count - 1
        Item = Items(n)
        Sh.Cells(n + 2, 1).Resize(1, 3) = Item
    Next
End Sub

If List.Exists(Key) Then
            A = List.Item(Key)
            A(1) = A(1) + Total
            A(2) = A(2) + reg
            List.Item(Key) = A
        Else
            List.Item(Key) = Array(Key, Total, reg)
        End If

For n = 0 To List.Count - 1