Macro para hacer rápida el recorrido de miles de celdas en una columna
Adjunto el código con el cual el código "For i = 2 To 40000" recorre 40,000 filas. Quisiera saber si el código adjunto se puede optimizar para que la macro se realice más rápido ya que se demora mucho así como esta.
Agradezco por las enseñanzas.
'inicializo la variable j
j = 2
'comienzo el bucle
For i = 2 To 40000
'activo la hoja donde están mis datos
Sheets("Report").Activate
'compruebo que el valor que sea mayor a 0
If Cells(i, "B").value > 0 Then
'copio la fila entera
Range(Cells(i, "A"), Cells(i, "BB")).Cut
'selecciono la hoja donde quiero pegar y después la celda
Sheets("PreDespacho").Activate
Range("A1").Select
Do While ActiveCell <> Empty
ActiveCell.Offset(1, 0).Select
Loop
'pego la fila que hemos copiado
ActiveSheet.Paste
'aumento la variable j para que vaya a la siguiente fila de la hoja filtros
'cuando encuentre una nueva fila que cumple con la condición de edad
j = j + 1
End If
Next
'elimino las filas vacias
Sheets("Report").Activate
Set a = Sheets("Report")
uf = a.Range("A" & Rows.Count).End(xlUp).Row
For x = uf To 2 Step -1
If a.Cells(x, 1) = Empty Then Cells(x, 2).EntireRow.Delete
Next x
Por el momento puedes
Poner lo siguiente
Application.screenUpdating= False antes de j=2
y justo antes de end Sub escribe
Application.screenUpdating= True
En cuanto tenga un tiempo libre o un espacio, le acomodamos el With para aligerar otro poco
O si gustas enviame mientras tu libro con pocos datos para agilizar nombrar hojas y de más
1 respuesta más de otro experto
En volúmenes de información como los que quieres manejar la programación que usas es bastante ineficiente como ya pudiste verlo, para esos caso se usa una programación encaminada manejar bloques de información en vez de hacerlo uno a uno o mediante ciclos do while esos para este tipo de caso no sirve, te paso esta macro pruébalas es bastante rápida, si tiene uno solo copiara 1, si tienes 40,000 0 50,000 o un millón de filas igual la macro se adaptara copiando solo lo que tengas. Pruébalas y me dices cuanto se tardo.
Sub cortar_datos()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
inicio = Time
Set h1 = Worksheets("report").Range("a1").CurrentRegion
Set h2 = Worksheets("predespacho")
With h1
filas = .Rows.Count: columnas = .Columns.Count
Set h1 = .Rows(2).Resize(filas - 1)
.Copy: h2.Range("a1").PasteSpecial
.ClearContents
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
Application.CutCopyMode = False
fin = Time
tiempo = fin - inicio
MsgBox ("copia hecha en " & Second(tiempo) & " segundos")
End Sub