1

Tengo una macro que acumula valores de filas determinados segun columnas similares, funciona bien con una tabla de datos intermedia en cuanto a su tiempo de ejecucion, 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 codigo que estoy utilizando a continuacion:

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 codigo que lo haga por el metodo 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

Ademas si fuese posible que este codigo 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 compilacion.

Anexo un archivo ejemplo en el siguiente link: https://drive.google.com/file/d/1Roz6uTXeFeS6d9dmsf8LuaLvEnJNbrAj/view?usp=sharing Espero me puedan ayudar con esto, saludos

0

1 respuesta 1

3

No tengo claro si necesitas mantener todos los datos de la hoja Compilado o no. Yo he incluido únicamente los que se mencionan en las columnas de tú código. Si necesitaras más sólo habría que añadirlos al array del diccionario y luego recuperarlos.

Te presento mi modo de hacerlo, algo más rudimentario pero funcional y rápido:

Sub test_acumulado()

    Dim wk As Worksheet, sht As Worksheet
    Dim arr As Variant, arrDatos As Variant
    Dim i As Long, x As Long
    Dim dicc As Object
    Dim clave As Variant, Key As Variant

    Set wk = ThisWorkbook.Sheets("Compilado")
    Set dicc = CreateObject("Scripting.Dictionary")
    arr = wk.UsedRange
    
    For i = 2 To UBound(arr)
        clave = arr(i, 1) & ";" & arr(i, 4) & ";" & arr(i, 11)
        If Not dicc.exists(clave) Then
            ReDim arrTmp(2)
            arrTmp(0) = arr(i, 13)      'Volumen
            arrTmp(1) = arr(i, 20)      'Longitud
            arrTmp(2) = 1               'Número de filas coincidentes
            dicc.Add clave, arrTmp
        Else
            Tmparr = dicc(clave)
            Tmparr(0) = Tmparr(0) + arr(i, 13)  'Sumo volumenes
            Tmparr(1) = Tmparr(1) + arr(i, 20)  'Sumo longitudes
            Tmparr(2) = Tmparr(2) + 1           'Sumo 1 a la cantidad de veces que aparece esa fila
            dicc(clave) = Tmparr
        End If
        
    Next
    
    'Datos a un array para volcar a la hoja
    ReDim arrDatos(dicc.Count - 1, 5)
    x = 0
    For Each Key In dicc.keys
        'Reutilizo la variable clave
        clave = Split(Key, ";")
        arrDatos(x, 0) = clave(0)
        arrDatos(x, 1) = clave(1)
        arrDatos(x, 2) = clave(2)
        arrDatos(x, 3) = dicc(Key)(0) 'Volumenes sumados
        arrDatos(x, 4) = dicc(Key)(1) 'Longitudes sumadas
        arrDatos(x, 5) = dicc(Key)(2) 'Numero de veces que aparece el dato
        x = x + 1
    Next
    'Nueva hoja
    Set sht = ThisWorkbook.Sheets.Add
    sht.Name = "Resultados"
    'Pego datos del array a la hoja
    sht.Range("A1").Resize(UBound(arrDatos) + 1, UBound(arrDatos, 2) + 1) = arrDatos

End Sub

Pruébalo y nos cuentas.

EDITO para aclarar tus dudas: Las columnas se añaden justo después del IF. Cada vez que vayas a añadir una columna debes redimensionar arrTmp y añadirle 1 su dimensión. Por ejemplo, si quieres añadir la columna E (posición 5) haces esto:

ReDim arrTmp(3)
arrTmp(0) = arr(i, 13)      'Volumen
arrTmp(1) = arr(i, 20)      'Longitud
arrTmp(2) = arr(i, 5)       'Columna E
arrTmp(3) = 1               'Número de filas coincidentes

Como la posición que cuenta el nº de filas coincidentes ha cambiado (arrTmp(3)) debes también tenerlo en cuenta en el ELSE y modificarlo:

Tmparr = dicc(clave)
Tmparr(0) = Tmparr(0) + arr(i, 13)  'Sumo volumenes
Tmparr(1) = Tmparr(1) + arr(i, 20)  'Sumo longitudes
Tmparr(3) = Tmparr(3) + 1           'Sumo 1 a la cantidad de veces que aparece esa fila
dicc(clave) = Tmparr

Y por último, en el array de datos (arrDatos) debes añadir esa columna:

ReDim arrDatos(dicc.Count - 1, 6) 'Redimensiono el array (de 5 a 6 pues hay una columna más)
x = 0
For Each Key In dicc.keys
    'Reutilizo la variable clave
    clave = Split(Key, ";")
    arrDatos(x, 0) = clave(0)
    arrDatos(x, 1) = clave(1)
    arrDatos(x, 2) = clave(2)
    arrDatos(x, 3) = dicc(Key)(0) 'Volumenes sumados
    arrDatos(x, 4) = dicc(Key)(1) 'Longitudes sumadas
    arrDatos(x, 5) = dicc(Key)(2) 'Columna E
    arrDatos(x, 6) = dicc(Key)(3) 'Numero de veces que aparece el dato
    x = x + 1
Next

Un saludo.

3
  • 1
    Muchas gracias por compartir esta macro realmente me es de gran utilidad; como podria agregar mas columnas al resultado como mencionas, es decir, no perder la estructura incial de la tabla cuando se agrupan y suman los datos incluyendo los encabezados? para esto deberia declarar las columnas a agregar con una variable Dim, agregarlas al array del diccionario con .add y luego repuperarlas con (Key)? lo he intentado de esta forma pero no logro hacerla funcionar, por ahora em cuesta entender un poco el manejo de array's en vba, nuevamente gracias por la ayuda brindada el 16 sep. 2022 a las 12:55
  • 1
    Hola, he editado la respuesta para explicarte cómo añadir más datos. Lo que hay que modificar es el array (arrTmp) y añadir tantas dimensiones como columnas vayas a incluir. La clave (key) no hay que tocarla para nada.
    – dogwall
    el 19 sep. 2022 a las 5:00
  • 1
    Muchas gracias, me es muy útil y me quedo muy clara tu explicación adicional, funciona muy bien. el 19 sep. 2022 a las 5:43

Tu Respuesta

By clicking “Publica tu respuesta”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

¿No es la respuesta que buscas? Examina otras preguntas con la etiqueta o formula tu propia pregunta.