Sacar subtotal por cada cambio de mes

Por favor colaborarme para que para cada cambio de mes se inserte una fila y se saque un subtotal. Gracias

Sub Buscar()
'Mod.Por.DAM
    Application.ScreenUpdating = False
    Set h1 = Sheets("Estados de cuenta")
    Set h2 = Sheets("Cartera.")
    '
    h1.Range("A18:E6000").ClearContents
    j = 18
    Set r = h2.Columns("G")
    Set b = r.Find(h1.Range("A6"), LookIn:=xlValues, LookAt:=xlWhole)
    If Not b Is Nothing Then
        ncell = b.Address
        Do
            h1.Cells(j, "A") = h2.Cells(b.Row, 4)
            h1.Cells(j, "B") = h2.Cells(b.Row, 9)
            h1.Cells(j, "C") = h2.Cells(b.Row, 5)
            h1.Cells(j, "D") = h2.Cells(b.Row, 2)
            h1.Cells(j, "E") = h2.Cells(b.Row, 8)
            j = j + 1
            Set b = r.FindNext(b)
        Loop While Not b Is Nothing And b.Address <> ncell
    End If
    h1.Range("A17:F17").AutoFilter
    u1 = h1.Range("A" & Rows.Count).End(xlUp).Row
    With h1.Sort
        .SortFields.Clear
        .SortFields.Add Key:=h1.Range("E17:E" & u1), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=h1.Range("A17:A" & u1), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange h1.Range("A17:F" & u1)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Selection.AutoFilter
    Application.ScreenUpdating = True
    MsgBox "Consulta terminada"
End Sub

Sub Guarda()

    Application.ScreenUpdating = False
    Dim Nombrearchivo As String
        mydir = ThisWorkbook.Path
        ChDir (mydir)
    Application.DisplayAlerts = False
    Nombrearchivo = Range("A6").Value
    Sheets("Estados de cuenta").Copy
    ActiveWorkbook.SaveAs Filename:=mydir & "\" & Nombrearchivo & ".xlsx"
    With Range("A:Z")
        .Copy
        .PasteSpecial xlPasteValues
    End With
     ruta = Range("A13").Value
    ActiveWorkbook.Close SaveChanges:=False
    Call Correo

End Sub
Sub Correo()

Dim OutApp As Object
Dim OutMail As Object

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.logon
Set OutMail = OutApp.createitem(0)

adjunto = Environ("temp") & "\" & ActiveSheet.Range("a6") & ".xlsx"

ActiveSheet.Copy

With Range("A:Z")
    .Copy
    .PasteSpecial xlPasteValues
End With

If Dir(adjunto) <> "" Then Kill adjunto
With ActiveWorkbook
  .SaveAs Filename:=adjunto, FileFormat:=51
  .Close False
End With

On Error Resume Next

With OutMail

.To = ActiveSheet.Range("A13")

.CC = ActiveSheet.Range("A14")

.Subject = " Estado de Cuenta " & ActiveSheet.Range("A6") & " AL " & Format(Now, "dd-MMMM-YYYY")

.body = "Estimado Socio " & ActiveSheet.Range("A6") & Chr(10) & Chr(10) _
& " Le Adjuntamos archivo de Excel con su respectivo estado de cuenta al dia " & Format(Now, "dd-MMMM-YYYY") _
& Chr(10) & Chr(10) & "Le solicitamos de la manera mas atenta nos facilite los detalles y comprobantes de pago a las siguientes direcciones:" _
& Chr(10) & Chr(10) & " [email protected]" & " " & Chr(10) & "[email protected]" _
& Chr(10) & Chr(10) _
& "Cualquier consulta con todo gusto" & Chr(10) & Chr(10) _
& "Sin otro particular por el momento, quedamos de ustedes." & Chr(10) & Chr(10) _
& "Departamento de Cobranzas" & Chr(10) _
& "inmoviliaria Latin America | [email protected]" & Chr(10) _
& "Ascapotzalco 2, Building 4, Ascapotzalco, Mexico" & Chr(10) _
& "Save Money. Live Better" & Chr(10) & Chr(10)

.Attachments.Add adjunto
.send
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing

MsgBox "Correo Enviado", vbInformation, "Estado de Cuenta"

End Sub