Sub ПереТоп_InExSu()
' примените нужный фильтр
    ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy
    Worksheets.Add
    ActiveSheet.Paste
    Z = [a1].CurrentRegion.Sort([h1], xlDescending, Header:=xlYes)
    [a1].CurrentRegion.RemoveDuplicates Columns:=5, Header:=xlYes
    Range(Rows("7:7"), Rows("7:7").End(xlDown)).Delete
End Sub

Option Explicit

Sub ПереТоп2()
Dim per, n!, r!, k!, lr, m(), tek!, dt, pr, u, i, j, rz(), max, nm
per = InputBox("Укажите период в формате dd.mm.yyyy-dd.mm.yyyy", "Период", "01.01.2015-15.01.2015")
If InStr(1, per, "-") = 0 Then GoTo osh
per = Split(per, "-")
If Not IsDate(per(0)) Or Not IsDate(per(0)) Then GoTo osh
n = DateValue(per(0)): k = DateValue(per(1))
Dim sl: Set sl = CreateObject("Scripting.Dictionary")

With Лист1
    lr = .Cells(.Rows.Count, 1).End(xlUp).Row
    m = .Cells(1, 1).Resize(lr, 8).Value
    For r = 2 To UBound(m)
    dt = m(r, 4) & "." & get_n(m(r, 3)) & "." & m(r, 1)
    tek = DateValue(dt)
        If tek >= n Then
            If tek <= k Then
                sl(m(r, 5)) = sl(m(r, 5)) + m(r, 7)
            End If
        End If
    Next r
End With

ReDim rz(1 To 5, 1)
For i = 1 To 5
    u = sl.keys
    max = 0
    For r = 0 To UBound(u)
        If max < sl(u(r)) Then max = sl(u(r)): nm = u(r)
    Next r
    rz(i, 0) = nm
    rz(i, 1) = max
    sl.Remove (nm)
Next i
  Worksheets.Add
  [a1].Resize(5, 2) = rz
    Cells.Columns.AutoFit
Exit Sub

osh:
MsgBox "Не корректный период", vbCritical, ""

End Sub

Private Function get_n(s)
    Dim i
    For i = 1 To 12
        If LCase(MonthName(i)) = LCase(s) Then
            get_n = i
            Exit Function
        End If
    Next i
End Function

Sub ПереТоп_InExSu()
' примените нужный фильтр
    ActiveSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy
    ' Worksheets.Add
    Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False
    With ActiveSheet
        .Range("i1") = "Доход"
        .Range("I2").FormulaR1C1 = "=RC[-2]-RC[-1]"
        .Range("j1") = "Сумма Дохода"
        .Range("J2").FormulaR1C1 = "=SUMIF(C[-5],RC[-5],C[-1])"
        .Range(.Cells(2, 9), .Cells(.UsedRange.Rows.Count, 10)).FillDown
        Application.CalculateFull
        .Range(Columns(9), Columns(10)).Copy
        .Range(Columns(9), Columns(10)).PasteSpecial _
                Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
        Application.CutCopyMode = False
        .UsedRange.RemoveDuplicates Columns:=Array(5, 10), _
                    Header:=xlYes
        Z = [a1].CurrentRegion.Sort([j1], xlDescending, Header:=xlYes)
        Range(Rows("7:7"), Rows("7:7").End(xlDown)).Delete Shift:=xlUp
    End With
End Sub