Macro copiar datos con una condición
He creado una macro para copiar datos de una hoja1 a hoja2 con una condición ; que si en la fila A de hoja1 sale la palabra "Entrega" copia la fila entera en hoja2 . La macro funciona pero tarda muchísimo en ejecutarse, ¿no se porque es? Creia que con la macro sería mucho más fácil que un copiar pegar.
Necesito que sea mucho más ágil, si alguien me puede ayudar
Esta es la macro que utilizo.
Sub copiarentregas()
filalibre = Sheets("ENTREGAS").Range("a30000").End(xlUp).Row + 1
dato = "Entrega"
If dato = "" Then Exit Sub
Set buscado = ActiveSheet.Range("a2:a" & Range("a30000").End(xlUp).Row).Find(dato, LookIn:=xlValues, lookat:=xlWhole)
If Not buscado Is Nothing Then
ubica = buscado.Address
Do
buscado.EntireRow.Copy Destination:=Sheets("ENTREGAS").Cells(filalibre, 1)
filalibre = filalibre + 1
Set buscado = ActiveSheet.Range("a2:a" & Range("a35000").End(xlUp).Row).FindNext(buscado)
Loop While Not buscado Is Nothing And buscado.Address <> ubica
End If
End Sub
2 Respuestas
En lugar de un ciclo, vamos a hacer un filtro en la columna "A" con lo que diga "Entrega"; y copias el filtro resultante.
Prueba con lo siguiente:
Sub Copiar_Entrega()
'
' Por.Dante Amor
'
Application.ScreenUpdating = False
Set h1 = ActiveSheet
Set h2 = Sheets("ENTREGAS")
If h1.AutoFilterMode Then h1.AutoFilterMode = False
h1.Range("A1").CurrentRegion.AutoFilter Field:=1, Criteria1:="Entrega"
u1 = h1.Range("A" & Rows.Count).End(xlUp).Row
u2 = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
If u1 > 1 Then
h1.Range("A2:F" & u1).Copy h2.Range("A" & u2)
MsgBox "Registros copiados", vbInformation
Else
MsgBox "No existen registros a copiar", vbExclamation
End If
If h1.AutoFilterMode Then h1.AutoFilterMode = False
Application.ScreenUpdating = True
End Sub.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
.
Avísame cualquier duda
.
[Hola
Te paso una nueva macro
Sub copyEntregas()
'Por Adriel Ortiz
'
Set h1 = ActiveSheet
Set h2 = Sheets("ENTREGAS")
'
cond = "Entrega"
For i = 2 To h1.Range("A" & Rows.Count).End(xlUp).Row
If h1.Cells(i, "A") = cond Then
u = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
h1.Rows(i).Copy h2.Range("A" & u)
u = u + 1
End If
Next i
'
Application.CutCopyMode = False
MsgBox "Fin"
End SubValora mi contribución como +Excelente o bueno para finalizar saludos!