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 Sub

Estoy 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 Sub

Ademá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

1 Respuesta

Respuesta
1

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 Sub

Saludos

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 Sub

Te 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 Sub

Probé la macro con los 500,000 registros, en mi equipo tarda 10 segundos.

Pone los datos en la hoja "Resultado"

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas