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