Crear un ciclo por VBA

hola Jose,

no estoy seguro del todo de si te he entendido, pero si quieres haz una prueba con este codigo (aunque es largo, si se
acerca a lo que buscas se podria fragmentar y hacer mas dinamico, aparte de haber otras opciones que lo simplificarian
<sobre todo a la hora de elegir la columna y el criterio>)

prueba con copias, pero asegurate de que las hojas se llamen exactamente como lo has expuesto en tu codigo.

hay un par de detalles (aparte de los que puedan surgir) que tendrias que tener en cuenta:

1º.- no se lo que tienes en las columnas de la c a la m en la hoja de destino, pero quizas convendria que lo borraras
antes de ejecutar la macro, pues sino te pegaria los datos pero si el contenido de estas es mayor que el nuevo, el resto
se mantendrian

2º.- como no estoy muy seguro de si lo que quieres realmenrte es pegar los datos de la columna BC o los de la anterior a
la que elijas para la busqueda (field), que es lo que pareceria por el ej. => buscas en la columna 56 (BD) y copias los
de la 55 (BC) te lo he puesto para el caso de que si sea solo esta pero si fuera lo que te comento (la anterior a Field)
cambia esta parte del codigo=>

.Range("BC" & pF & ":bc" & uF).Copy
' .Range(.Cells(pF, Columna - 1), .Cells(uF, Columna - 1)).Copy

poniendo una comilla simple delante de => .Range("BC" & pF & ":bc" & uF).Copy

y quitando la que hay delante de => ' .Range(.Cells(pF, Columna - 1), .Cells(uF, Columna - 1)).Copy

en definitiva te deberia quedar +/- asi =>

' .Range("BC" & pF & ":bc" & uF).Copy
.Range(.Cells(pF, Columna - 1), .Cells(uF, Columna - 1)).Copy

bueno, pegalo en un modulo 'normal' (una vez copiado el libro => Alt+F11 => en el editor de vba => menu 'Insertar' =>
Modulo (a secas, o normal, etc, pero NO de clase) => y en esta ventana que se te abre pegas este codigo =>

'''-pega desde aqui--´'
'
Sub CicloVba()
Dim Columna As Integer, rngCol As Variant, _
criterio As Long, pF As Long, uF As Long, _
Ref As String, preMsj As String, celda As Range
Do
On Error Resume Next
Application.DisplayAlerts = False
criterio = Application.InputBox(preMsj & _
"Elige un nº entre 4101 y 4112", _
"Elegir criterio", 4101, , , , , 1)
Application.DisplayAlerts = True
On Error GoTo 0
If criterio = False Then GoTo Salir
preMsj = "El numero introducido no es valido." & vbCr
Loop While criterio < 4101 Or criterio > 4112
preMsj = ""
With Sheets("Base de datos 10-1-08")
.Activate
Application.ScreenUpdating = False
Do
On Error Resume Next
Set rngCol = Application.InputBox(preMsj & _
"Selecciona la celda de titulo de la columna " & _
"en donde quieres buscar el nº: " & criterio, _
"Elegir campo de busqueda", "BD1", , , , , 8)
If rngCol = False Then GoTo Salir
Columna = rngCol.Cells(1).Column
If Err.Number <> 0 Or Columna < 2 Or Columna > 104 Then
If preMsj = "" Then preMsj = _
"El rango seleccionado no es correcto" & vbCr
End If
On Error GoTo 0
Loop Until Columna > 1 And Columna < 105
rngCol.CurrentRegion.Sort Key1:=rngCol.Offset(1), _
Order1:=xlAscending, Header:=xlYes
If Application.CountIf(.Columns(Columna), criterio) > 0 Then
With .Range(.Cells(1, Columna), .Cells(65536, Columna).End(xlUp))
Set celda = .Find(criterio, .Cells(1), xlValues)
Ref = celda.Address: pF = celda.Row
Do
uF = celda.Row
Set celda = .FindNext(celda)
Loop While celda.Address <> Ref
Set celda = Nothing
End With
.Range("BC" & pF & ":bc" & uF).Copy
' .Range(.Cells(pF, Columna - 1), .Cells(uF, Columna - 1)).Copy
Sheets("núms. extrac. x rutas ").Cells(4, criterio - 4098) _
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
End With
Exit Sub
Salir:
MsgBox "No se ha podido completar la operacion."
End Sub
'
''pega hasta aqui-

un saludo y si ves que te puede valer, si quieres comentas y lo intentamos ajustar y simplificar
Ivan

hola, Jose !

__ 1 __

He grabado una macro de... copiar en una hoja los codigos (numeros) de extraccion de fichas correspondientes a determinadas rutas.
... necesitaria que alguien me lo simplificase para que se haga en un loop (for-next u otros).

__ 2 __

... me gustaria que pudiera elegir el field (ahora es siempre 56) y... elegir tambien el criterial (del 4101 al 4112) esto... no tan importante.
El resultado copiado esta en la columna BC de la hoja "Base de datos 10-1-08"
El pegado (numeros) es en la hoja "nums. extrac. x rutas ", y seria siempre en las celdas desde C4 a N4 respectivamente.

__ 3 __

Anadir si es posible la deteccion de errores y que no se vea el proceso...

1) "basicamente", el bucle for...next que solicitas (con los detalles del codigo que expones) puedes simplificarlo +/- a lo siguiente:

Sub Filtra_Rutas()
Dim Col As Byte, Origen As String, Destino As String
Origen = "base de datos 10-1-08"
Destino = "núms. extrac. x rutas "
With Worksheets(Origen).Range("a2:dz2").CurrentRegion
For Col = 1 To 12
.AutoFilter Field:V, Criteria1:A00 + Col
Worksheets(Destino).Range("c4").Offset(, Col * 2 - 2) _
.EntireColumn.ClearContents
With .Parent.AutoFilter.Range
.Offset(, 54).Resize(, 1).Copy _
Worksheets(Destino).Range("c4").Offset(, Col * 2 - 2)
End With
Next
.AutoFilter
End With
End Sub

2) para "tomar" de variables el field y el criteria1 (y dependera de otras -posibles- implicaciones), podrias p.e.
- usar rangos para el field y el criteria1 (probablemente varios fields en otro bucle "externo" al del criteria1)
- definir matrices en el mismo codigo vba (con un manejo similar al anterior)
- obtenerlos del usuario (p.e.) desde InputBoxes (o formularios)
- etc. etc. etc.

3) manejo de errores ?... (tal como va la propuesta no deberia haber errores)...
si algun filtro no se da... pasa en blanco el pegado (pero la columna donde iria... sera "saltada" para el siguiente ciclo)

que no se vea el proceso ?... puedes evitar las instrucciones ".Select" (para no danzar entre hojas y rangos)...
(si "calificas" totalmente a cual hoja y rango se aplican las instrucciones, no es necesaria esta "danza")
y/o... puedes (tambien) usar al principio de tu macro la instruccion: Application.ScreenUpdating = False

4) (seguramente) habra algunos detalles que no se alcanzan a apreciar (desde este lado del mensaje) p.e.
- necesitas (o es no/conveniente ?) borrar los rangos en la hoja de destino ? (comentado por Ivan)
- que pasaria con las columnas "C" en adelante (hoja de destino) cuando el bucle inicie NO en 1 ? (For Col = 1 To .)
- o cuando el criteria1 sea de un tipo de datos no-numerico ?
(habra que cambiar el bucle "For <contador>..." a "For Each <variable>..." y usar un contador ajustable dentro del ciclo)

si cualquier duda (o informacion adicional)... cometas ?
saludos,
hector.

__ el codigo expuesto __

Sub Macroparafichasxrutas()
Sheets("Base de datos 10-1-08").Select
Range("A2:DZ2").Select
Selection.AutoFilter
Selection.AutoFilter Field:V, Criteria1:="4101"
Range("BC536:BC782").Select
Selection.Copy
Sheets("núms. extrac. x rutas ").Select
Range("C4").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Sheets("Base de datos 10-1-08").Select
Selection.AutoFilter Field:V, Criteria1:="4102"
Range("BC184:BC642").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("núms. extrac. x rutas ").Select
Range("D4").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Sheets("Base de datos 10-1-08").Select
Selection.AutoFilter Field:V, Criteria1:="4103"
Range("BC161:BC171").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("núms. extrac. x rutas ").Select
Range("E4").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Sheets("Base de datos 10-1-08").Select
Selection.AutoFilter Field:V, Criteria1:="4104"
Range("BC109:BC130").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("núms. extrac. x rutas ").Select
Range("F4").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
End Sub

hola Hector, (y Jose)

solo aprovechar para saludarte a la que le comento una cosilla a Jose

como veras sigo a años luz del 'kiss', incluso yo diria que aun mas
retorcidillo si cabe. Bueno, tiempo al tiempo (aunque sea mucho)

en cuanto a Jose, solo comentar que si te diera por probar mi codigo,
convendria que cambiaras esto =>

rngCol.CurrentRegion.Sort Key1:=rngCol.Offset(1), _
Order1:=xlAscending, Header:=xlYes

por esto =>

rngCol.CurrentRegion.Sort Key1:=rngCol.Cells(1).Offset(1), _
Order1:=xlAscending, Header:=xlYes

solo por si acaso

un saludo
Ivan

hola, Ivan !

... sigo a años luz del 'kiss', incluso yo diria que aun mas retorcidillo si cabe.
Bueno, tiempo al tiempo (aunque sea mucho) ...

puesto que (casi) siempre se encuentran formas de mejorar el rendimiento de (casi) cualquier proceso...
el principio del "kiss" no deja de ser otro ciclo de repeticiones "indeterminadas" (hasta alcanzar su "minima expresion")
el tiempo (en estos casos), pasa a ser un factor (mas de tipo personal) donde intervienen otros factores (in/controlables ?)

saludos,
hector.

Gracias a los dos por vuestos códigos. Los he utilizado en parte y a base de
muchas pruebas, voy consiguiendo mis objetivos con VBA. Pero creerme me
cuenta gran trabajo y hago multitud de pruebas y grabaciones... ufff.
vosotros me ayudais muchisimo y por ellos os doy las gracias de nuevo. Si no
os importa os iré pasando preguntas rápidas y concretas sobre líneas de
código que no sé preparar...
Saludos


"Héctor Miguel" escribió en el mensaje
news:%

hola, Ivan !

... sigo a años luz del 'kiss', incluso yo diria que aun mas retorcidillo
si cabe.
Bueno, tiempo al tiempo (aunque sea mucho) ...

puesto que (casi) siempre se encuentran formas de mejorar el rendimiento
de (casi) cualquier proceso...
el principio del "kiss" no deja de ser otro ciclo de repeticiones
"indeterminadas" (hasta alcanzar su "minima expresion")
el tiempo (en estos casos), pasa a ser un factor (mas de tipo personal)
donde intervienen otros factores (in/controlables ?)

saludos,
hector.