Macro que en una celda vea si se cumple condición
HOLA, estoy tratando de hacer una macro que en una celda vea si se cumple una condición, si es así que copie la celda activa, sino es así baje una linea y nuevamente evalúe la condición en la nueva celda pra copiar si se cumple o seguir sino, esto hasta llegar a la celda que yo le indique por ejemple la celda a100, lo que yo tengo es lo siguiente y lo hace bien con la primera celda que encuentra y cumple la condición, pero no con las siguiente:
Agradecido de vuestra colaboración
Sub copyfila()
Dim RANGO
Dim dire
Dim dire1
dire = Rows("14:14").Address 'HACE VARIABLE A LAS FILAS
dire = 1
dire1 = 2
RANGE("D1").Select
RANGO = 10
While RANGO <> 1000
If ActiveCell.Value = 10 Then
Sheets("HOJA1").Select
ActiveCell.EntireRow.Select
Selection.Copy
Sheets("muestra").Select
Rows(dire1).Select
ActiveSheet.Paste
dire1 = dire1 + 1
RANGO = RANGO + 1
Sheets("HOJA1").Select
Else
ActiveCell.Offset(1, 0).Activate
RANGO = RANGO + 1
End If
Wend
End Sub
Agradecido de vuestra colaboración
Sub copyfila()
Dim RANGO
Dim dire
Dim dire1
dire = Rows("14:14").Address 'HACE VARIABLE A LAS FILAS
dire = 1
dire1 = 2
RANGE("D1").Select
RANGO = 10
While RANGO <> 1000
If ActiveCell.Value = 10 Then
Sheets("HOJA1").Select
ActiveCell.EntireRow.Select
Selection.Copy
Sheets("muestra").Select
Rows(dire1).Select
ActiveSheet.Paste
dire1 = dire1 + 1
RANGO = RANGO + 1
Sheets("HOJA1").Select
Else
ActiveCell.Offset(1, 0).Activate
RANGO = RANGO + 1
End If
Wend
End Sub
{"Lat":-46.5588603031172,"Lng":-73.125}
1 respuesta
Respuesta de emoren
1
Bueno acá le dejo una rutina que hace lo que solicitas la cual la voy a ir comentado:
Sub copiar()
'seleccionamos la hoja y la primer celda que se debe evaluar
Sheets("Hoja1").Range("E6").Select
'establecemos un bucle FOR al cual le especificamos que se ejecute hasta 16 veces
For x = 1 To 16
'comenzamos a evaluar las celdas verificando que se cumpla la condicion diferente de 1000
If (ActiveCell.Value <> 1000) Then
'si se cumple bajamos una celda
ActiveCell.Offset(1, 0).Select
Else
'si no se cumple evaluamos nuevamente a ver si es igual a 1000
If (ActiveCell.Value = 1000) Then
'si se cumple obtenemos la direccion de la celda activa
direccion = ActiveCell.address
'copiamos el contenido de la celda
ActiveCell.Copy
'nos dirigimos a la hoja donde queremos pegar la informacion
Sheets("Hoja2").Select
'seleccionamos la celda donde se debe comenzar a evaluar otro bucle que establecemos con el fin de encontrar la ultima celda vacia para ir pegando los datos copiados
Range("A2").Select
'el bucle do while (mientras que no este vacia la celda activa)
Do While Not IsEmpty(ActiveCell)
'si se cumple esta condicion bajamos una celda
ActiveCell.Offset(1, 0).Select
'se evalua nuevamente la condicion hasta que no se cumpla
Loop
'en la celda activa pegamos el dato que hemos copiado
ActiveSheet.Paste
'seleccionamos nuevamente la hoja para seguir evaluando las celdas
Sheets("Hoja1").Select
'seleccionamos la ultima celda evaluada
Range(direccion).Select
'bajamos una celda
ActiveCell.Offset(1, 0).Select
End If
End If
'se repite nuevamente el bucle hasta que se ejecute 16 veces que fue lo que establecimos
Next
End Sub
Todo este código cópielo y peguelo en su proyecto, tenga en cuenta que debe acoplarlo en su proyecto de acuerdo a sus necesidades y datos, no se preocupe por borrar los comentarios que en vba el asume que son comentarios y no los tiene en cuenta, si ud gusta escríbame una dirección de correo electrónico al correo [email protected] y con gusto le envío el archivo donde hice esta macro para que vea como trabaja, a mi me funciona muy bien o me envía el archivo bien descrito y con gusto le acoplo la macro.
Espero mi explicación le sea de utilidad, cualquier duda recuerde que puede consultarme nuevamente que con gusto le colaboro, NO OLVIDAR PUNTUAR Y FINALIZAR LA PREGUNTA.
Sub copiar()
'seleccionamos la hoja y la primer celda que se debe evaluar
Sheets("Hoja1").Range("E6").Select
'establecemos un bucle FOR al cual le especificamos que se ejecute hasta 16 veces
For x = 1 To 16
'comenzamos a evaluar las celdas verificando que se cumpla la condicion diferente de 1000
If (ActiveCell.Value <> 1000) Then
'si se cumple bajamos una celda
ActiveCell.Offset(1, 0).Select
Else
'si no se cumple evaluamos nuevamente a ver si es igual a 1000
If (ActiveCell.Value = 1000) Then
'si se cumple obtenemos la direccion de la celda activa
direccion = ActiveCell.address
'copiamos el contenido de la celda
ActiveCell.Copy
'nos dirigimos a la hoja donde queremos pegar la informacion
Sheets("Hoja2").Select
'seleccionamos la celda donde se debe comenzar a evaluar otro bucle que establecemos con el fin de encontrar la ultima celda vacia para ir pegando los datos copiados
Range("A2").Select
'el bucle do while (mientras que no este vacia la celda activa)
Do While Not IsEmpty(ActiveCell)
'si se cumple esta condicion bajamos una celda
ActiveCell.Offset(1, 0).Select
'se evalua nuevamente la condicion hasta que no se cumpla
Loop
'en la celda activa pegamos el dato que hemos copiado
ActiveSheet.Paste
'seleccionamos nuevamente la hoja para seguir evaluando las celdas
Sheets("Hoja1").Select
'seleccionamos la ultima celda evaluada
Range(direccion).Select
'bajamos una celda
ActiveCell.Offset(1, 0).Select
End If
End If
'se repite nuevamente el bucle hasta que se ejecute 16 veces que fue lo que establecimos
Next
End Sub
Todo este código cópielo y peguelo en su proyecto, tenga en cuenta que debe acoplarlo en su proyecto de acuerdo a sus necesidades y datos, no se preocupe por borrar los comentarios que en vba el asume que son comentarios y no los tiene en cuenta, si ud gusta escríbame una dirección de correo electrónico al correo [email protected] y con gusto le envío el archivo donde hice esta macro para que vea como trabaja, a mi me funciona muy bien o me envía el archivo bien descrito y con gusto le acoplo la macro.
Espero mi explicación le sea de utilidad, cualquier duda recuerde que puede consultarme nuevamente que con gusto le colaboro, NO OLVIDAR PUNTUAR Y FINALIZAR LA PREGUNTA.
Finalizar esta pregunta ya que fue hecha 2 veces y ya esta solucionada.
