Optimizar macro para combinar filas
Tengo una macro que acumula valores de filas determinados según columnas similares, funciona bien con una tabla de datos intermedia en cuanto a su tiempo de ejecución, lo que quiero es optimizar esta macro o mejorarla ya que tengo tablas de hasta 500mil datos en las que se demora demasiado tiempo, comparto el código que estoy utilizando a continuación:
Sub Acumular()
Application.ScreenUpdating = False
ActiveSheet.Copy after:=ActiveSheet
For x = Range("A" & Rows.Count).End(xlUp).Row To 3 Step -1
i1 = InStrRev(Range("D" & x), " ")
i2 = InStrRev(Range("D" & x - 1), " ")
If i1 = 0 Then i1 = Len(Range("D" & x))
If i2 = 0 Then i2 = Len(Range("D" & x - 1))
If Left(Range("D" & x), i1) = Left(Range("D" & x - 1), i2) And _
Range("K" & x) = Range("K" & x - 1) And Range("A" & x) = Range("A" & x - 1) Then
Range("D" & x - 1) = Left(Range("D" & x - 1), i2)
Range("B" & x - 1) = Left(Range("B" & x - 1), i2)
Range("M" & x - 1) = Range("M" & x - 1) + Range("M" & x)
Range("T" & x - 1) = Range("T" & x - 1) + Range("T" & x)
Rows(x).Delete
End If
Next
Range("A1").Select
End SubEstoy tratando de hacer un código que lo haga por el método Scriptin.Dictionary aun sin buenos resultados, comparto lo que llevo adelantado
Sub CombineRows()
'
Dim WorkRng As Range
Dim Dic As Variant
Dim arr As Variant
On Error Resume Next
xTitleId = "BoQ'sforExcel"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
Set Dic = CreateObject("Scripting.Dictionary")
arr = WorkRng.Value
For i = 1 To UBound(arr, 1)
Dic(arr(i, 1)) = Dic(arr(i, 1)) + arr(i, 13) 'Sum Volume
Dic(arr(i, 1)) = Dic(arr(i, 1)) + arr(i, 20) 'Sum Length
Next
Application.ScreenUpdating = False
WorkRng.ClearContents
WorkRng.Range("A1").Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.keys)
WorkRng.Range("D1").Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.keys)
WorkRng.Range("K1").Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.keys)
WorkRng.Range("M1").Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.items)
WorkRng.Range("T1").Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.items)
Application.ScreenUpdating = True
End SubAdemás si fuese posible que este código agregara otra columna con nombre "count", donde se fuera acumulando el valor de numero de veces que la fila se encuentra en la tabla y se agrupe bajo el mismo criterio de compilación.
Anexo un archivo ejemplo en el siguiente link: https://drive.google.com/file/d/1Roz6uTXeFeS6d9dmsf8LuaLvEnJNbrAj/view?usp=sharing
3 respuestas
Te invito a suscribirte a mi canal de youtube:
Tutoriales Excel y Macros - YouTube
Ahí encontrarás sobre las mejores prácticas para programar en VBA.
Revisa los siguientes ejemplos sobre el uso de matrices:
Macro para copiar datos de un libro a otro utilizando Matrices - YouTube
Macro Cargar Listbox con Matriz - YouTube
El segundo vídeo explica un pequeño ejemplo sobre el uso del Dictionary.
Intenta realizar la macro y me comentas.
¡Gracias! Voy apoyarme en tus videos y seguir intentando crear la macro y te comento como me fue.
Dante Amor he tratado de modificar el codigo que llevaba adelantado, pero aun sin buenos resultados, como podria realizar el proceso sin perder la estructura incial de la tabla cuando se agrupan y suman los datos incluyendo los encabezados, comparto el codigo que he intenda ejecutar
Sub CombineRows()
'
Dim WorkRng As Range
Dim Dic As Variant
Dim arr As Variant
Set WorkRng = Range("A1").CurrentRegion
Set Dic = CreateObject("Scripting.Dictionary")
arr = WorkRng.Value
For i = 1 To UBound(arr, 1)
If Dic(arr(i, 1)) = arr(i, 1) And Dic(arr(i, 1)) = arr(i, 4) And Dic(arr(i, 1)) = arr(i, 11) Then
Dic(arr(i, 1)) = arr(i, 1)
Dic(arr(i, 1)) = arr(i, 4)
Dic(arr(i, 1)) = arr(i, 11)
Dic(arr(i, 1)) = Dic(arr(i, 1)) + arr(i, 13) 'Sum Volume
Dic(arr(i, 1)) = Dic(arr(i, 1)) + arr(i, 20) 'Sum Length
End If
Next
Application.ScreenUpdating = False
WorkRng.ClearContents
WorkRng.Range("A1").Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.keys)
WorkRng.Range("D1").Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.keys)
WorkRng.Range("K1").Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.keys)
WorkRng.Range("M1").Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.keys)
WorkRng.Range("T1").Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.keys)
Application.ScreenUpdating = True
End SubSaludos
Ya descargué tu archivo ejemplo.
Podrías explicarme con los datos que tienes en ese archivo. ¿Qué necesitas?
@Dante Amor Gracias por ayudarme con el tema, lo que necesito es agrupar las filas iguales según los valores de las columna A, D, K, sumando los valores de las columnas M y T, adicional a esto, cuando se compile la tabla, esta debe incluir o agregar una columna con nombre "Count" que cuente las filas que se repiten y sume el resultado.
Todo esto manteniendo la estructura inicial de la tabla, es decir, todas la columnas restantes. Saludos
Tu macro del post original no está funcionando correctamente, ya que si los registros no están continuos u ordenados, entonces realiza varias acumulaciones para los mismos datos delos valores A, D, K.
Si vas a utilizar un Dictionary, primero debes llenar el Dictionary con los valores de las columnas A, D, K, de esa manera tendremos los valores únicos. ¿Eso es lo que quieres?
Correcto, esos valores únicos deben acumular o sumar los valores de las columnas M y T y agregar una columna (count) que cuente las filas unicas para mostrar la suma de este en el resultado final; manteniendo todos lo encabezados de las columnas. Gracias nuevamente por tu tiempo y ayuda.
Te paso la macro actualizada:
Sub Acumjular_v2()
'Por Dante Amor
Dim sh1 As Worksheet, sh2 As Worksheet
Dim dic As Object
Dim a As Variant, b As Variant
Dim i As Long, j As Long, n As Long, y As Long
Dim llave As String
'
Set sh1 = Sheets("Compilado") 'hoja Origen
Set sh2 = Sheets("Resultado") 'hoja Destino
Set dic = CreateObject("Scripting.Dictionary")
'
If sh1.AutoFilterMode Then sh1.AutoFilterMode = False
a = sh1.Range("A2:AJ" & sh1.Range("A" & Rows.Count).End(3).Row).Value 'datos Origen
ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2) + 1) 'agregamos una columna para el contador
'
For i = 1 To UBound(a, 1)
If i = 64 Then
i = i
End If
'La llave contiene las columnas 1, 4 y 11 (A, D y K)
llave = a(i, 1) & "|" & a(i, 4) & "|" & a(i, 11)
If Not dic.exists(llave) Then
y = y + 1 'incrementamos la fila de la matriz de salida
n = 1 'inicia contador con 1
Else
y = Split(dic(llave), "|")(0)
n = Split(dic(llave), "|")(1) + 1 'incrementa el contador
End If
'llenamos el Dictionary con la llave:=key, dato:=fila "|" contador
dic(llave) = y & "|" & n
'entonces en la matriz de salida, en la fila 'y' ponemos los datos
For j = 1 To UBound(a, 2)
Select Case j
Case 13, 20 'acumulamos columnas M y T
b(y, j) = b(y, j) + a(i, j)
Case Else
b(y, j) = a(i, j)
End Select
Next
b(y, j) = n 'actualiza el contador en la última columna
Next
With sh2
.Cells.ClearContents
sh1.Rows(1).Copy .Range("A1")
.Range("A2").Resize(dic.Count, UBound(b, 2)).Value = b
End With
End SubTe invito a suscribirte a mi canal
https://www.youtube.com/channel/UCs644-v3ti4SF7zE_bt_YXA
No olvides la valoración.
¡Muchas gracias! funciona perfecto
Solamente por curiosidad, cuánto tiempo tarda en ejecutarse la macro con 500,000 registros.
Se demora muy poco (menos de un segundo), y es que fijándome con mayor detalle en la información compilada, no se por que no incluye todos los valores teniendo en cuenta las condiciones planteadas en las líneas del código, creo algo debe ver con estas líneas
If i = 64 Then i = i End If
Puedes compartir el archivo con una muestra de los datos que no se reflejan.
Si el archivo con 500,000 registros no es muy grande, entonces comparte el archivo completo y comenta cuáles datos no se reflejan.
If i = 64 Then i = i End If
Esa parte, la puedes eliminar del código, la puse para realizar una prueba y se me pasó eliminarla.
Muchas gracias por tu constante ayuda en el tema, te comparto el archivo completo https://drive.google.com/file/d/1lcR-tyuEBMuOrmapHr4O2KhZ7G8duXZe/view?usp=sharing ,
Me di cuenta que no estaba compilando todos los datos por los filtro de datos de la primera columna que muestro a continuacion, deberian ser los mismos en el caso de las columnas A, D, K
La macro quita el autofiltro de la hoja.
No puedo descargar el archivo.
Podrías compartir un extracto de la información que dices que no incluye los valores.
Te comparto el archivo con los datos que no compilan filtrados https://drive.google.com/file/d/1lcR-tyuEBMuOrmapHr4O2KhZ7G8duXZe/view?usp=sharing , gracias nuevamente
No estoy entendiendo a qué te refieres con "los datos que no compilan filtrados"
La hoja debe estar sin filtro y la macro considera todos los datos.
Puedes explicar.
Podrías decirme solamente un registro que no se está considerando.
En el archivo que te comparto en la hoja "Compilado" en la columna A esta el valor MB-1110, que cuando ejecuto la macro no lo contempla en la hoja "Resumen"
Ya revisé cuál es el problema.
Te paso la macro actualizada.
Nota: Es recomendable trabajar con la instrucción "Option Explicit"
Sub Acumjular_v2()
'Por Dante Amor
Dim sh1 As Worksheet, sh2 As Worksheet
Dim dic As Object
Dim a As Variant, b As Variant
Dim i As Long, j As Long, k As Long, n As Long, y As Long
Dim llave As String
'
Set sh1 = Sheets("Compilado") 'hoja Origen
Set sh2 = Sheets("Resultado") 'hoja Origen
Set dic = CreateObject("Scripting.Dictionary")
'
If sh1.AutoFilterMode Then sh1.AutoFilterMode = False
a = sh1.Range("A2:AJ" & sh1.Range("A" & Rows.Count).End(3).Row).Value 'datos Origen
ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2) + 1) 'agregamos una columna para el contador
'
For i = 1 To UBound(a, 1)
'La llave contiene las columnas 1, 4 y 11 (A, D y K)
llave = a(i, 1) & "|" & a(i, 4) & "|" & a(i, 11)
If Not dic.Exists(llave) Then
y = y + 1 'incrementamos la fila de la matriz de salida
n = 1 'inicia contador con 1
dic(llave) = y & "|" & n
Else
k = Split(dic(llave), "|")(0)
n = Split(dic(llave), "|")(1) + 1 'incrementa el contador
dic(llave) = k & "|" & n
End If
'llenamos el Dictionary con la llave:=key, dato:=fila "|" contador
k = Split(dic(llave), "|")(0)
n = Split(dic(llave), "|")(1)
'entonces en la matriz de salida, en la fila 'y' ponemos los datos
For j = 1 To UBound(a, 2)
Select Case j
Case 13, 20 'acumulamos columnas M y T
b(k, j) = b(k, j) + a(i, j)
Case Else
b(k, j) = a(i, j)
End Select
Next
b(k, j) = n 'actualiza el contador en la última columna
Next
'
With sh2
.Cells.ClearContents
sh1.Rows(1).Copy .Range("A1")
.Range("A2").Resize(dic.Count, UBound(b, 2)).Value = b
End With
End SubProbé la macro con los 500,000 registros, en mi equipo tarda 10 segundos.
Pone los datos en la hoja "Resultado"
Option Explicit
Public Sub ConsolidarRapido()
Dim ws As Worksheet, wsOut As Worksheet
Dim rng As Range, data As Variant
Dim dict As Object, k As Variant, itm As Variant
Dim i As Long, nCols As Long, nOut As Long
Dim outArr() As Variant
'=== CONFIGURA TU RANGO DE ENTRADA ===
Set ws = ActiveSheet
Set rng = ws.Range("A1").CurrentRegion ' encabezados en fila 1
nCols = rng.Columns.Count
'=== OPTIMIZACIONES DE ENTORNO ===
Dim calcPrev As XlCalculation, evtPrev As Boolean
calcPrev = Application.Calculation
evtPrev = Application.EnableEvents
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
'=== LECTURA A MEMORIA ===
data = rng.Value ' 1-based: data(fila, col)
Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
' Recorre filas de datos (desde 2: asumiendo encabezados en 1)
For i = 2 To UBound(data, 1)
Dim key As String
Dim Akey As String, Kkey As String, Dstem As String, Bstem As String
Akey = CStr(data(i, 1)) ' Col A
Kkey = CStr(data(i, 11)) ' Col K (11)
Dstem = StemSinUltimaPalabra(data(i, 4)) ' Col D
Bstem = StemSinUltimaPalabra(data(i, 2)) ' Col B (si quieres mantenerla “recortada”)
key = Akey & "§" & Kkey & "§" & Dstem
If Not dict.Exists(key) Then
' Guarda: A, Btrim, Dtrim, K, sumM, sumT, count
dict.Add key, Array( _
Akey, _
Bstem, _
Dstem, _
Kkey, _
CDbl(Nz(data(i, 13))), _ ' M (13)
CDbl(Nz(data(i, 20))), _ ' T (20)
1)
Else
itm = dict(key)
itm(4) = itm(4) + CDbl(Nz(data(i, 13))) ' acumula M
itm(5) = itm(5) + CDbl(Nz(data(i, 20))) ' acumula T
itm(6) = itm(6) + 1 ' count
dict(key) = itm
End If
Next i
'=== PREPARA SALIDA ===
nOut = dict.Count
ReDim outArr(1 To nOut, 1 To nCols + 1) ' +1 para "count"
Dim r As Long: r = 0
For Each k In dict.Keys
r = r + 1
itm = dict(k)
' Coloca lo que te interesa en las columnas originales
outArr(r, 1) = itm(0) ' A
outArr(r, 2) = itm(1) ' B (recortada)
outArr(r, 4) = itm(2) ' D (recortada)
outArr(r, 11) = itm(3) ' K
outArr(r, 13) = itm(4) ' M (suma)
outArr(r, 20) = itm(5) ' T (suma)
outArr(r, nCols + 1) = itm(6) ' count al final
Next k
'=== HOJA DE SALIDA ===
Set wsOut = Worksheets.Add(After:=ws)
On Error Resume Next
wsOut.Name = ws.Name & "_Consolidado"
On Error GoTo 0
' Copia encabezados y agrega "count"
wsOut.Range("A1").Resize(1, nCols).Value = rng.Rows(1).Value
wsOut.Cells(1, nCols + 1).Value = "count"
' Vuelca datos
wsOut.Range("A2").Resize(nOut, nCols + 1).Value = outArr
'=== RESTAURA ENTORNO ===
Application.ScreenUpdating = True
Application.Calculation = calcPrev
Application.EnableEvents = evtPrev
End Sub
Private Function StemSinUltimaPalabra(ByVal v As Variant) As String
' Devuelve el texto recortado hasta ANTES del último espacio.
Dim s As String, p As Long
s = Trim$(CStr(v))
If Len(s) = 0 Then
StemSinUltimaPalabra = ""
Exit Function
End If
p = InStrRev(s, " ")
If p > 0 Then
StemSinUltimaPalabra = Left$(s, p - 1)
Else
StemSinUltimaPalabra = s
End If
End Function
Private Function Nz(ByVal v As Variant) As Double
' Convierte vacío/error/texto vacío a 0; si es número, lo devuelve.
If IsError(v) Then
Nz = 0
ElseIf IsNumeric(v) Then
Nz = CDbl(v)
ElseIf Len(Trim$(CStr(v))) = 0 Then
Nz = 0
Else
' Si es texto numérico con separadores, intenta convertir
On Error Resume Next
Nz = CDbl(Replace(CStr(v), ",", Application.DecimalSeparator))
If Err.Number <> 0 Then Nz = 0
On Error GoTo 0
End If
End FunctionPor qué esto vuela con 500k filas
0 borrados de filas (la peor operación en Excel).
2 I/O con la hoja: leer todo a data y escribir todo desde outArr.
Agrupado en memoria con Dictionary (O(1) promedio por inserción/búsqueda).
Clave compuesta robusta (A | K | D_tronco).
Si quieres variar el criterio
¿Quieres qué el “tronco” de B no se recorte? Cambia Bstem = StemSinUltimaPalabra(data(i, 2)) por Bstem = CStr(data(i, 2)).
¿Quieres agregar más columnas sumables? Añádelas al array itm y al cálculo, igual que con M y T.
¿El “tronco” de D debe cortar por otro carácter (p. ej. “-”)? Cambia la función StemSinUltimaPalabra.
¿Te armo una versión que tome automáticamente el rango de datos de una Tabla (ListObject) y elija por nombre las columnas A/B/D/K/M/T aunque estén en otro orden?
