Macro para copiar en hoja2 las filas de una BBDD que contienen "14" en su celdas de columna A

el 10 de octubre

Buenas tardes,

Ojalá me podáis ayudar. Realizo una tarea repetitiva de obtención de datos CAT, BBDD en bruto similar al Excel que adjunto aunque mucho más largos. Y entre otros tengo que filtrar y depurar las filas que empiezan por "14", pasarlas a Hoja2 y ordenar de mayor a menor por columna T. En total son 3 acciones bastante sencillas:

Paso 1: Filtro las filas que tienen el dato "14" en sus celdas de la columna A, copia los datos resultantes y los pego en Hoja 2.

Paso 2: Cambio el formato de las celdas de la columna T a integuer o Entero a través de una formula. Seguro que hay un atajo pero no lo conozco. La finalidad es que Excel reconozca los datos de estas celdas como números.

Paso 3: Ordeno las filas resultantes de mayor a menor por esa columna T, que ahora sí reconoce como número.

Heintentado escribir una Macro que resuelva estos pasos con un click ya que lo realizo repetitivamente y me resulta imposible. Hace mucho tiempo que no redacto Macros y no recuerdo casi nada. A ver si me podéis ayudar por favor que no doy con ello y me sería de enorme utilidad. Mil gracias.

Formato_CAT_tipo14_Paterna.xls

Antoni · el 10 de octubre

Hola Tueresjorge:

Sub Copiar14()
Application.ScreenUpdating = False
Hoja1.Select
Hoja2.Cells.Clear
Range("A1").Select
Do Until ActiveCell = ""
   If CInt(ActiveCell) = 14 Then
      fila = fila + 1
      Rows(ActiveCell.Row).Copy Hoja2.Rows(fila)
      Hoja2.Range("T" & fila) = CInt(Hoja2.Range("T" & fila))
      Hoja2.Range("T:T").HorizontalAlignment = xlRight
   End If
   ActiveCell.Offset(1, 0).Select
Loop
Hoja2.Select
Hoja2.UsedRange.Sort key1:=Hoja2.Range("T:T")
Application.ScreenUpdating = True
End Sub
[/code]

Saludos.

el 11 de octubre

Re: Macro para copiar en hoja2 las filas de una BBDD que contienen "14" en su celdas de columna A

Eres un Crack Marco Antonio. Va estupendo.

Mil gracias!

Jorge

- - - - - Mensaje combinado - - - - -

Macro Antonio!

Antoni · el 11 de octubre

Hola Jorge:

Te adjunto de nuevo la macro un poco mas optimizada.

Las diferencias básicas sobre la versión anterior son:

Los registros de la Hoja1 se van marcando a medida que se van procesando con un "1" en la columna "AB", que creo es la primera columna vacía.

Solo se procesan los registros que tienen vacía esa columna.

El proceso siempre añade filas en la Hoja2, es decir, no se borran los datos al principio del proceso tal como hacíamos en la macro anterior.

Todo esto nos permite ejecutar la macro tantas veces como queramos con la seguridad de no duplicar información.

Tienes un seguimiento del avance de proceso en la fila de estado de Excel.

He hecho una prueba con 60.000 registros y no ha llegado a los 10 minutos. (Pentium II a 1,6 Mz)

Sub Copiar14()

Application.ScreenUpdating = False
Hoja1.Select


On Error Resume Next
fila = Hoja2.Range("A" & Rows.Count).End(xlUp).Row + 1
On Error GoTo 0


Hora = Time
Application.StatusBar = Hora & " Procesando fila 1 "


'===================================================
Range("A1").Select
Do Until ActiveCell = ""
   If ActiveCell.Row Mod 100 = 0 Then
      Application.StatusBar = Hora & " Procesando fila " & ActiveCell.Row & " " & Time
   End If
   If Range("AB" & ActiveCell.Row) = "" Then
      Range("AB" & ActiveCell.Row) = "1"
      If CInt(ActiveCell) = 14 Then
         Catorce = True
         Rows(ActiveCell.Row).Copy Hoja2.Rows(fila)
         Hoja2.Range("T" & fila) = CInt(Hoja2.Range("T" & fila))
         fila = fila + 1
      End If
   End If
   ActiveCell.Offset(1, 0).Select
Loop
'===================================================


Application.StatusBar = Hora & " Ordenando datos ..." & Time
Hoja2.Select
Hoja2.Range("T:T").HorizontalAlignment = xlRight
If Range("A1") = "" Then Rows(1).Delete
Columns("AB:AB").Delete
If Catorce = True Then Hoja2.UsedRange.Sort key1:=Hoja2.Range("T:T")
Application.StatusBar = "Listo"
Application.ScreenUpdating = True
MsgBox Hora & " Proceso terminado " & Time


End Sub


[/code]

Antoni · el 11 de octubre

Hola Jorge:

He conseguido triplicar el rendimiento (20.000 registros por minuto).

La macro empieza analizando desde el final de la "Hoja1" y va eliminando los registros distintos de 14 haciendo un break cada 1.000 registros para optimizar.

En cualquier momento puedes pulsar Escape y puedes cancelar el proceso, guardar y volver a ejecutar la macro en cualquier otro momento sin perder el trabajo hecho.

Ya me contarás.

Sub EliminarNo14()

Dim Rango As Range


Application.ScreenUpdating = False
Hoja1.Select
Hora = Time


filas = Range("A" & Rows.Count).End(xlUp).Row
Bucle:
   For filas = filas To 1 Step -1
      If contador = 1000 Or filas = 1 Then Exit For
      contador = contador + 1
      If Range("A" & filas) <> 14 Then
         If Rango Is Nothing = True Then
            Set Rango = Rows(filas)
         Else
            Set Rango = Union(Rango, Rows(filas))
         End If
      End If
   Next

   Application.StatusBar = Hora & " Procesando fila " & filas & " " & Time
   If Rango Is Nothing = False Then
      Rango.EntireRow.Delete
   End If
   Set Rango = Nothing
   contador = 0
   If filas > 1 Then GoTo Bucle

Ordenar:
   Application.StatusBar = Hora & " Ordenando datos ..." & Time
   ActiveSheet.Range("T:T").HorizontalAlignment = xlRight
   ActiveSheet.UsedRange.Sort key1:=ActiveSheet.Range("T:T")
   Application.StatusBar = "Listo"
   Application.ScreenUpdating = True
   MsgBox Hora & " Proceso terminado " & Time


End Sub


[/code]