Macro afinar subtotales listado vba excel

Ingeniero Dante Amor

Feliz de contar siempre con su ayuda, en esta ocasión me podría ayudar a afinar su macro de una pregunta anterior, el cual realicé unos ajustes para que me sumara más de una columna y le antepusiera un título. Por cierto si hay más formas de hacerlo, me gustaría aprender.

Lo requerido:

1. No logro que en el último subtotal me coloque en negrillas toda la fila

2. He realizado varias pruebas con datos de finales y en algunos casos no me realiza las sumatorias, algo curioso porque he comparado datos y no veo la falla.

resultado:

el código:

'Dante Amor
Sub subtotales()
  Dim i As Long, ini As Long, fin As Long
  Dim ant As String
  Dim una As Boolean
  Dim subti As String
  Dim subt As Double
  Dim subt2 As Double
  Dim subt3 As Double
  Dim subt4 As Double
  '
  Application.ScreenUpdating = False
  '
  ant = ""
  una = True
  For i = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
    If una Then
      fin = i
      una = False
    Else
      If ant <> Range("A" & i).Value Then
        Range("F" & fin + 1).Value = subti
        Range("G" & fin + 1).Value = subt
        Range("H" & fin + 1).Value = subt2
        Range("I" & fin + 1).Value = subt3
        Range("J" & fin + 1).Value = subt4
        Rows(i + 1).Resize(2).Insert
        Rows(i + 1).Font.Bold = True
        fin = i
        subti = "TOTAL"
        subt = 0
        subt2 = 0
        subt3 = 0
        subt4 = 0
      End If
    End If
    subti = "TOTAL"
    subt = subt + Range("G" & i).Value
    subt2 = subt2 + Range("H" & i).Value
    subt3 = subt3 + Range("I" & i).Value
    subt4 = subt4 + Range("J" & i).Value
    ant = Range("A" & i).Value
  Next
  '
  Range("F" & fin + 1).Value = subti
  Range("G" & fin + 1).Value = subt
  Range("H" & fin + 1).Value = subt2
  Range("I" & fin + 1).Value = subt3
  Range("J" & fin + 1).Value = subt4
  Application.ScreenUpdating = True
End Sub
Respuesta
5

Prueba la siguiente macro:

Sub subtotales()
  Dim i As Long, ini As Long, fin As Long
  Dim ant As String, subti As String
  Dim una As Boolean
  Dim subt1 As Double, subt2 As Double, subt3 As Double, subt4 As Double
  '
  Application.ScreenUpdating = False
  '
  subti = "TOTAL"
  ant = ""
  una = True
  For i = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
    If una Then
      fin = i
      una = False
    Else
      If ant <> Range("A" & i).Value Then
        Range("F" & fin + 1).Value = subti
        Range("G" & fin + 1).Value = subt1
        Range("H" & fin + 1).Value = subt2
        Range("I" & fin + 1).Value = subt3
        Range("J" & fin + 1).Value = subt4
        Rows(fin + 1).Font.Bold = True
        Rows(i + 1).Resize(2).Insert
        Rows(i + 1).Font.Bold = True
        fin = i
        subt1 = 0
        subt2 = 0
        subt3 = 0
        subt4 = 0
      End If
    End If
    subt1 = subt1 + Range("G" & i).Value
    subt2 = subt2 + Range("H" & i).Value
    subt3 = subt3 + Range("I" & i).Value
    subt4 = subt4 + Range("J" & i).Value
    ant = Range("A" & i).Value
  Next
  '
  Range("F" & fin + 1).Value = subti
  Range("G" & fin + 1).Value = subt1
  Range("H" & fin + 1).Value = subt2
  Range("I" & fin + 1).Value = subt3
  Range("J" & fin + 1).Value = subt4
  Application.ScreenUpdating = True
End Sub

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas