Instrucción en VBA para hacer que la macro se ejecute más rápido

Tengo un archivo super pesado, donde tiene 4 hojas, en cada hoja hay aproximadamente 600.000 registros y la macro lo que hace es que añade una hoja nueva, y consolida la información que se filtra de las 4 hojas de acuerdo a una celda que hay en otro archivo, entonces filtra esas 4 hojas consolida en la hoja nueva, para luego copiar todo en esa hoja nueva y pegarlo en el otro archivo. El tema es que como es tanta la información, ese proceso es muyyyyyyyy demorado ("EN ESPECIAL LA PARTE QUE FILTRA"), quisiera ustedes me ayudaran a checar mi código y si puedo hacer más rápido o optimizar el código. Mil gracias.

Sub Extraer_Info_SAP()
Application.DisplayAlerts = False
a = Range("G13").Text
b = Range("H13").Text
c = Range("G18").Text
d = Range("H18").Text
Dim MyFile As String
Dim pctCompl As Single
MyPath = Range("G2").Text
MyFile = Dir(MyPath)
Workbooks.OpenText FileName:=a
Sheets("0L").Select
Do While MyFile <> ""
If MyFile Like "*.xlsx" Then
Workbooks.Open MyPath & MyFile
Sheets("Formato ").Select Range("Z4").Select
ActiveCell.FormulaR1C1 = Mid(Mid(ActiveWorkbook.Name, 33, 33), 1, 11)
criterio = Sheets("Formato ").Cells(4, 26)
Workbooks(b).Activate
Ultimafila = "AL" & ActiveSheet.Columns("A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
Dim xWs As Worksheet
On Error Resume Next
For Each xWs In Worksheets
xWs.Range("A1:" & Ultimafila).AutoFilter 10, criterio
Next
For Each hoja In ActiveWorkbook.Sheets
If hoja.Name = "todas" Then hoja.Delete
Next
Sheets.Add before:=Sheets(1)
ActiveSheet.Name = "todas"
For x = 2 To Sheets.Count
Sheets(x).Select
Range("a1:al" & Range("a1048576").End(xlUp).Row).Copy
Sheets("todas").Range("a1048576").End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll
Next
Sheets("todas").Select
Rows("1:1").Select
Selection.Delete Shift:=xlUp
Cells.Select
Selection.Copy
Workbooks(MyFile).Activate
Sheets("Movimiento Cuenta en Compañía").Select
Range("a1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("a1").Select
Sheets("Formato ").Select Range("A1").Select
Workbooks.OpenText FileName:=c
Sheets("Todas").Select
Cells.Select
Selection.Copy
Workbooks(MyFile).Activate
Sheets("Balance").Select
Range("a1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("a1").Select
Sheets("Formato ").Select Range("A1").Select
ActiveWorkbook.Close True
End If
MyFile = Dir
Loop
End Sub

Respuesta
1

Hay varias cosas que hacer con tu rutina que si cambias/modificas definitivamente la harán mucho más rápida:

1- Declara todas las variables y no te confundas con el tipo, hay varias con las que no lo has hecho. Ejemplo: Dim a As String, b As String, c As String, de As String

2- Quita el "parpadeo"/actualización de la pantalla. Coloca "Application.ScreenUpdating=False" y "Application.ScreenUpdating=True" al final.

3- Evita "seleccionar" rango y/u hojas. Por ejemplo, esto:

Sheets(x).Select
Range("a1:al" & Range("a1048576").End(xlUp).Row).Copy
Sheets("todas"). Range("a1048576").End(xlUp).Offset(1, 0). PasteSpecial xlPasteAll

Puede ser reemplazado por esto:

Sheets(x). Range("a1:al" & Range("a1048576").End(xlUp). Row). Copy
Sheets("todas"). Range("a1048576").End(xlUp).Offset(1, 0). PasteSpecial xlPasteAll

Y de esas tienes varias.

4- Evita seleccionar toda una columna, toda una fila, o todas las celdas de una hoja. Por ejemplo, usas "Cells.Select". Busca alternativas como "UsedRange" o "CurrentRegion".

Esas cosas como para comenzar

Abraham Valencia

Muchísimas gracias, he realizado esos cambios, ¿Alguna sugerencia para lo demás?

En general, como te comenté, busca que otros "Select" puede evitar. (Re)Acomoda tu macro y nos la vuelves a enviar, así podemos darle otro vistazo. Por cierto, con los cambios que mencionas ya incluiste ¿han reducido en algo el tiempo de ejecución?

Abraham Valencia

Hola Abraham mira ha quedado así:

Sub Extraer_Info_SAP()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
A = Range("G13").Text
b = Range("H13").Text
c = Range("G18").Text
d = Range("H18").Text
Dim MyFile As String
Dim pctCompl As Single
MyPath = Range("G2").Text
MyFile = Dir(MyPath)
Workbooks.OpenText FileName:=A
Sheets("0L").Select
Do While MyFile <> ""
If MyFile Like "*.xlsx" Then
Workbooks.Open MyPath & MyFile
Sheets("Formato ").Select Range("Z4").Select
ActiveCell.FormulaR1C1 = Mid(Mid(ActiveWorkbook.Name, 33, 33), 1, 11)
criterio = Sheets("Formato ").Cells(4, 26)
Workbooks(b).Activate
Ultimafila = "AL" & ActiveSheet.Columns("A").Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
Dim xWs As Worksheet
On Error Resume Next
For Each xWs In Worksheets
xWs.Range("A1:" & Ultimafila).AutoFilter 10, criterio
Next
For Each hoja In ActiveWorkbook.Sheets
If hoja.Name = "todas" Then hoja.Delete
Next
Sheets.Add before:=Sheets(1)
ActiveSheet.Name = "todas"
For x = 2 To Sheets.Count
Sheets(x).Range("a1:al" & Range("a1048576").End(xlUp).Row).Copy
Sheets("todas").Range("a1048576").End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll
Next
Sheets("todas").Rows("1:1").Select
Selection.Delete Shift:=xlUp
ActiveCell.CurrentRegion.Select
Selection.Copy
Workbooks(MyFile).Activate
Sheets("Movimiento Cuenta en Compañía").Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("a1").Select
Sheets("Formato ").Range("A1").Select
Workbooks.OpenText FileName:=c
Sheets("Todas").Select
Cells.Select
Selection.Copy
Workbooks(MyFile).Activate
Sheets("Balance").Select
Range("a1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("a1").Select
Sheets("Formato ").Range("A1").Select
ActiveWorkbook.Close True
End If
MyFile = Dir
Loop
Application.ScreenUpdating = True
End Sub

Aun sigue lenta :(,

Otro tema imaginate, que esta macro si le doy paso a paso, funciona el filtro, si no le doy paso a paso no filtra, hace el filtro pero no filtra nada sabes porque??

Primero, no olvides declarar las variables, eso también ayudará; segundo, aún tienes muchos "select" y líneas de código que redundan. Por ejemplo, esto:

Sheets("Todas").Select
Cells.Select
Selection.Copy
Workbooks(MyFile).Activate
Sheets("Balance").Select
Range("a1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("a1").Select
Sheets("Formato ").Range("A1").Select

Puedes reemplazarlo por:

Sheets("Todas").UsedRange.Copy Destination:= Workbooks(MyFile).Activate.Sheets("Balance").Range("a1")
Application.CutCopyMode = False

Y como ya te comenté, hay varias cosas de ese tipo en tu código.

Abraham Valencia

PD: Quizá aún se demora pero si tomas el tiempo te apuesto que cada vez un poco menos

Corrección:

Sheets("Todas"). UsedRange.Copy Destination:= Workbooks(MyFile). Sheets("Balance"). Range("a1")
Application.CutCopyMode = False

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas