Macros para calcular subtotales usando diccionarios


La siguiente macro tiene como antecedente:

Microsoft Scripting Runtime

  • Microsoft Scripting Runtime es un referencia necesaria para el uso de diccionarios en VBA





Problema:  Calcular el total y el sobtotal de adeudos para la siguiente lista de nombres:
Cálculo de subtotales usando diccionarios



Sub calculoSubtotales()
'Microsoft Scripting Runtime
'Cálcular subtotales utilizando diccionarios
Dim dicc As New Scripting.Dictionary

Dim columnaSalida As Integer
Dim k As Variant
Dim filaSalida As Long
Dim grantotalPalabras As Long
Dim palabra As String
Dim rango As Range
Dim celda As Variant

On Error Resume Next
Set rango = Application.InputBox(Prompt:="Seleccionar el rango de entrada de las palabras a buscar", _
                      Title:="Rango palabras", Type:=8)

Set dicc = New Scripting.Dictionary

For Each celda In rango
    palabra = celda
    
    If Not dicc.Exists(palabra) Then
        dicc.Item(palabra) = celda.Offset(0, 1).Value
    Else
        dicc.Item(palabra) = dicc.Item(palabra) + celda.Offset(0, 1).Value
    End If
    
Next celda

filaSalida = 1
columnaSalida = 3
grantotalPalabras = 0

Cells(filaSalida, columnaSalida + 1).Value = "Nombre"
Cells(filaSalida, columnaSalida + 2).Value = "Adeudo"

For Each k In dicc.Keys
    filaSalida = filaSalida + 1
    Cells(filaSalida, columnaSalida + 1).Value = k
    Cells(filaSalida, columnaSalida + 2) = dicc(k)
    grantotalPalabras = grantotalPalabras + dicc(k)
Next k

filaSalida = filaSalida + 1
Cells(filaSalida, columnaSalida + 1).Value = "GRAN TOTAL"
Cells(filaSalida, columnaSalida + 2).Value = grantotalPalabras

Set dicc = Nothing

End Sub


Tabla resultante al ejecutar la macro anterior:
Cálculo de subtotales usando diccionarios