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