Macro que me permita pasar a una celda antes de la misma columna
Private Sub btn_siguiente_Click()
'Por.Dante Amor
Titulo = "ACADEMIA DE CONDUCCIÓN"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set h1 = Sheets("EVALUACION")
Fila = ActiveCell.Row
If Fila < 3 Then Fila = 3
If Fila < 3 Or Fila > 42 Then
MsgBox "Ha llegado al final del cuestionario", vbInformation, Titulo
btn_atras.Enabled = True
btn_respuesta.Enabled = False
Exit Sub
Else
btn_atras.Enabled = True
btn_respuesta.Enabled = True
Set H2 = Sheets.Add
archivo = ThisWorkbook.Path & "\" & "temp.jpeg"
Rango = "J" & Fila 'Poner el rango a mostrar
Me.reloj.Caption = "Pregunta Nº: " & Fila - 2
anc = h1.Range(Rango).Width
alt = h1.Range(Rango).Height
h1.Range(Rango).CopyPicture
H2.Shapes.AddChart
With H2.ChartObjects(1)
.Width = anc + 2
.Height = alt + 2
.Chart.Paste
.Chart.Export archivo
.Delete
End With
H2.Delete
Label1.Picture = LoadPicture(archivo)
ActiveCell.Offset(1, 0).Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End If
End SubDam, la macro que me desarrollaste quedó de la anterior manera, como se debe avanzar a la siguiente fila teniendo en cuenta que debe ser de la fila 3 a 42 únicamente se indica con la linea:
ActiveCell.Offset(1, 0).Select 'para adelantar y ActiveCell.Offset(-1, 0).Select ' para retroceder a la anterior fila
Como me debe quedar para retroceder, lo hago pero tengo que hacer click dos veces para retroceder y al querer adelantar de nuevo, también debo hacer click dos veces, el código de retroceder que tengo es el siguiente:
Private Sub btn_atras_Click()
Titulo = "ACADEMIA DE CONDUCCIÓN"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set h1 = Sheets("EVALUACION")
ActiveCell.Offset(-1, 0).Select
Fila = ActiveCell.Row
If Fila < 3 Then Fila = 3
If Fila > 3 Or Fila < 42 Then
btn_atras.Enabled = True
btn_respuesta.Enabled = True
Set H2 = Sheets.Add
archivo = ThisWorkbook.Path & "\" & "temp.jpeg"
Rango = "J" & Fila 'Poner el rango a mostrar
Me.reloj.Caption = "Pregunta Nº : " & Fila - 2
anc = h1.Range(Rango).Width
alt = h1.Range(Rango).Height
h1.Range(Rango).CopyPicture
H2.Shapes.AddChart
With H2.ChartObjects(1)
.Width = anc + 2
.Height = alt + 2
.Chart.Paste
.Chart.Export archivo
.Delete
End With
H2.Delete
Label1.Picture = LoadPicture(archivo)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Else
MsgBox "Ha llegado a la Priemra pregunta del cuestionario", vbInformation, Titulo
btn_atras.Enabled = False
btn_respuesta.Enabled = False
btn_siguiente.Enabled = True
Exit Sub
End If
End SubAl retroceder y continuar el retroceso, y luego de llegar a la fila 1, lógicamente me genera el siguiente error que me marca el la linea "ActiveCell.Offset(-1, 0).Select":
Necesito saber como quedaría el código con los correspondientes limitantes y controles de errores.
1 Respuesta
H o l a:
Te cambio el código completo.
Primero, al iniciar el form, la primer pregunta que se debe mostrar es la 1, entonces vamos a poner el cursor en la celda J3 y mostramos la primer pregunta.
Private Sub UserForm_Activate()
'Por.Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Range("J3").Select
PonerPregunta ActiveCell.Row
End SubCuando presiones el botón siguiente se revisará si es la última pregunta, si es la última entonces que se vaya a la primera, si no es la última entonces avanzará una celda:
Private Sub btn_siguiente_Click()
'Por.Dante Amor
fini = 3 'número de fila de la PRIMER pregunta
ffin = 42 'número de fila de la última pregunta
ActiveCell.Offset(1, 0).Select
If ActiveCell.Row > ffin Then Range("J" & fini).Select
PonerPregunta ActiveCell.Row
End SubAlgo similar con el botón anterior, si llegó a la primera, entonces se irá a la última pregunta, si no es la primera, entonces retrocederá :
Private Sub btn_atras_Click()
'Por.Dante Amor
fini = 3 'número de fila de la PRIMER pregunta
ffin = 42 'número de fila de la última pregunta
ActiveCell.Offset(-1, 0).Select
If ActiveCell.Row < fini Then Range("J" & ffin).Select
PonerPregunta ActiveCell.Row
End SubPor último, en una macro independiente tenemos el código exclusivo para poner una imagen, el único parámetro que necesitas es el número de fila:
Sub PonerPregunta(fila)
'Por.Dante Amor
Titulo = "ACADEMIA DE CONDUCCIÓN"
Set h1 = Sheets("EVALUACION")
Set h2 = Sheets.Add
archivo = ThisWorkbook.Path & "\" & "temp.jpeg"
Rango = "J" & fila
Me.reloj.Caption = "Pregunta Nº: " & fila - 2
h1.Range(Rango).CopyPicture
h2.Shapes.AddChart
With h2.ChartObjects(1)
.Width = h1.Range(Rango).Width + 2
.Height = h1.Range(Rango).Height + 2
.Chart.Paste
.Chart.Export archivo
.Delete
End With
h2.Delete
Label1.Picture = LoadPicture(archivo)
End SubDe esta forma estarás "girando" entre las preguntas. Por ejemplo, si estás en la pregunta 42 y quieres ir a la pregunta 2, no tienes que retroceder, puedes avanzar a la 1 y luego a la 2.
Todo el código lo tienes que poner en el formulario. Me parece que no es necesario que actives y desactives los botones Siguiente y Anterior, ya que en cualquier momento podrías regresar o avanzar para contestar alguna pregunta pendiente.
¡Gracias! DAM, no lo había considerado de esa manera, pero como siempre de tu parte se conocen experiencias y sugerencias que hacen las soluciones más prácticas y sencillas.
Saludos.
