Sacar subotales por año arriba en la hoja

Ayudarme a que arriba aparezcan los totales por año de cada inquilino que vayamos a consultar

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

1 respuesta

Respuesta
2

Y qué valor se suma en los totales por año, ¿el de la columna "C" Importe?

Sí, esa columna.

Gracias

Esta es la macro para los totales

Sub subtotal()
'Por.Dante Amor
    Set h1 = Sheets("Estados de cuenta")
    c = "A"
    u = h1.Range("A" & Rows.Count).End(xlUp).Row
    ant = Month(h1.Cells(u, c))
    fin = u + 1
    wimporte = 0
    On Error Resume Next
    For i = u To 17 Step -1
        If ant <> Month(h1.Cells(i, c)) Then
            h1.Rows(fin).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            h1.Cells(fin, "C") = wimporte
            wimporte = 0
            fin = i + 1
        End If
        wimporte = wimporte + h1.Cells(i, "C")
        ant = Month(h1.Cells(i, c))
        Select Case Year(h1.Cells(i, c))
            Case 2012: h1.Range("D12") = h1.Range("D12") + h1.Cells(i, "C")
            Case 2013: h1.Range("D13") = h1.Range("D13") + h1.Cells(i, "C")
            Case 2014: h1.Range("D14") = h1.Range("D14") + h1.Cells(i, "C")
        End Select
    Next
End Sub

Saludos.Dante Amor

Recuerda valorar la respuesta.

La pregunta no admite más respuestas

Más respuestas relacionadas