Optimizar proceso Comprobación datos vba excel
Tengo macro que copia datos de una hoja Origen a otra Destino siempre y cuando el dato que intenta copiar no esté en la hoja destino.
Mi problema viene cuando son muchos los registros que debe comprobar, se ralentiza muchisimo y no veo la forma de agilizarlo.
Os adjunto un ejemplo, el archivo original es mucho más amplio.
En este ejemplo se puede ver perfectamente donde está el problema, hay unos 1800 registros.
Sub Ejecuta()
'---------------------------comenzamos a depurar.
'
Set WsOrigen = Sheets("Mes en Curso")
Set wsfinal = Sheets("Simulador")
wsfinal.Select
Dim finalwsorigen As Integer
Dim FinalWsDestino As Integer
Dim CuentaObrasActu As Integer
Dim RangoFormula As Range
'
finalwsorigen = WsOrigen.Range("A" & Rows.Count).End(xlUp).Row
FinalWsDestino = wsfinal.Range("A" & Rows.Count).End(xlUp).Row
'
' Se utilizan para actualizar un formulario que no hay en este ejemplo
CuentaObrasActu = 0
'
For I = 3 To finalwsorigen
'
CuentaObrasActu = CuentaObrasActu + 1
' Comenzamos a comprobar y poner obras.
For j = 2 To FinalWsDestino
If WsOrigen.Cells(I, "A") = wsfinal.Cells(j, "A") Then encontrado = 1
DoEvents
Application.StatusBar = " Registros actualizados: " & CuentaObrasActu
Next
If encontrado = 0 Then
Set wsorigen2 = Sheets("Simulador Base")
wsfinal.Select
'copia formula de A4 Simulador Base
FinalWsDestino = wsfinal.Range("A" & Rows.Count).End(xlUp).Row
wsorigen2.Range("A4:DB4").Copy Destination:=wsfinal.Range("A" & FinalWsDestino + 1)
Application.CutCopyMode = False
'Copia datos de mes en curso en simulador
WsOrigen.Cells(I, "A").Copy
wsfinal.Range("A" & FinalWsDestino + 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
' Si es una obra nueva, copiamos los datos de valores de pedido, aplicamos formatos y copiamos todas las formulas.
WsOrigen.Cells(I, "G").Copy
wsfinal.Range("BY" & FinalWsDestino + 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
encontrado = 0
Else
encontrado = 0
End If
Next
'
wsfinal.Select
'Copiamos la fila 1 de los subtotales de la plantilla Base Simulador en el Simulador, por si ha perdido la configuracion.
Wsorigen2.Range("B1:DA1").Copy Destination:=wsfinal.Range("B1")
'
'liberamos las variables de la memoria, liberamos memoria y recursos.
Application.StatusBar = "Proceso Terminado"
End Sub
1 respuesta
El problema radica en que estas haciendo la comparación 1 a 1 es decir si tienes 5000 filas y cada fila la quieres comparar realizara 25 millones de comparaciones y si hace le agregamos el hecho que pusiste un doevent y un status bar entonces tu macro va a correr a la velocidad de una lenta tortuga, así que una alternativa a esto es crear una macro que copie la columna A y la columna G como una tabla temporal luego abajo de esta copiar la columna A de la hoja simulador, después se eliminan los duplicados y se aplica la fórmula contar. Si los que resulten en 0 quiere decir que solo existen en la mes en curso y solo con esos realizara el copiado de datos todo este proceso en 5000 registros toma de 2 a 4 segundos, el único detalle que puede darte problemas es si tienes encabezados esta macro esta diseñada para trabajar a partir de la celda A1 de la hoja mes en curso y de la A3 de la hoja simular.
Sub comparar_columnas()
inicio = Timer
Set mes = Worksheets("mes en curso")
Set sim = Worksheets("simulador")
Set simb = Worksheets("simulador base")
Set datos = mes.Range("a4").CurrentRegion
Set datos2 = sim.Range("a4").CurrentRegion
Set datos3 = simb.Range("a4").CurrentRegion
With datos
filas = .Rows.Count
columnas = .Columns.Count
Set res = .Columns(columnas + 2).Resize(filas, 2)
Union(.Columns(1), .Columns(7)).Copy: res.PasteSpecial
End With
With datos2
filas2 = .Rows.Count
.Columns(1).Copy
res.Rows(filas + 1).Resize(filas2, 1).PasteSpecial
Set res = res.CurrentRegion
End With
With res
.RemoveDuplicates Columns:=1
Set res = res.CurrentRegion
.Columns(3).Formula = "=countif(simulador!" & datos2.Columns(2).Address & "," & .Cells(1, 1).Address(0, 0) & ")"
.Value = .Value
Set res = res.CurrentRegion
.Sort key1:=mes.Range(.Columns(3).Address), order1:=xlAscending
filas3 = .CurrentRegion.Rows.Count
For i = 1 To filas3
veces = .Cells(i, 3)
If veces > 0 Or .Cells(i, 2) = Empty Then Exit For
datos3.Copy: datos2.Rows(filas2 + i).PasteSpecial
res.Cells(i, 1).Copy: datos2.Cells(filas2 + i, 1).PasteSpecial
Next i
cuenta = WorksheetFunction.CountIfs(res.Columns(3), 0, .Columns(2), ">0")
.Columns(2).Resize(cuenta, 1).Copy: sim.Range("by" & filas2).Resize(cuenta, 1).PasteSpecial
res.CurrentRegion.Clear
End With
Set mes = Nothing: Set sim = Nothing: Set simb = Nothing
Set datos = Nothing: Set datos2 = Nothing: Set datos3 = Nothing
Set res = Nothing
fin = Timer
tiempo = fin - inicio
tiempo = Format(tiempo, "00:00:00")
MsgBox (filas & " procesadas en " & tiempo)
End Sub
