Jump to content

Archived

This topic is now archived and is closed to further replies.

Milton Cordova

Fromato en texto de imagen

Recommended Posts

Saludos me pueden ayudar muy comedidamente con la siguiente macro: mediante esta macro solo funciona cuando en la celda A1 ingreso manualmente al valor ya sea 1 o 0, lo que necesito es que en la celda A1 el valor venga de una formula de la celda B5.

Otra situación es cuando se ejecuta con 1 salta a la celda E7 y cuando se ejecuta con 0 salta a la celda B14, lo que deseo es que no salte ni seleccione ninguna celda.

La hoja la he protegido con una contraseña "X".

Favor analizar esta macro que he logrado

Private Sub Worksheet_Change(ByVal Target As Range)
ActiveSheet.Unprotect "X"
    Application.ScreenUpdating = False

  If Not Intersect(Target, Range("A1")) Is Nothing Then
If Range("A1").Value = 1 Then
ActiveSheet.Shapes("Rectangle 1").Select
    Selection.Font.ColorIndex = 0
    ActiveSheet.Shapes("Rectangle 2").Select
    Selection.Font.ColorIndex = 0
    Range("C7").Select
    ActiveSheet.Shapes("Line 3").Select
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 64
    Selection.ShapeRange.Line.Visible = msoTrue
ActiveSheet.Protect "X"

Else
If Range("A1").Value = 0 Then
ActiveSheet.Shapes("Rectangle 1").Select
    Selection.Font.ColorIndex = 2
    ActiveSheet.Shapes("Rectangle 2").Select
    Selection.Font.ColorIndex = 2
    Range("B14").Select
    ActiveSheet.Shapes("Line 3").Select
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 9
    Selection.ShapeRange.Line.Visible = msoTrue
    ActiveSheet.Protect "X"

    End If
    End If
    End If
End Sub

 

Cambia color Texto de imagenes.xls

Link to post
Share on other sites
En 12/10/2018 at 5:06 , Milton Cordova dijo:

mediante esta macro solo funciona cuando en la celda A1 ingreso manualmente al valor ya sea 1 o 0

Lógico con el evento Change de la hoja. Tendrás que cambiar la filosofía de la macro y usar el evento

Private Sub Worksheet_Calculate()

 

Link to post
Share on other sites

Saludos Antoni disculopas por indicarte que hice el cambio pero no funciona

quiza deba ingresar algun otro evento

Private Sub Worksheet_Calcualte(ByVal Target As Range)
Application.ScreenUpdating = False

If Not Intersect(Target, Range("A1")) Is Nothing Then
If Range("A1").Value = 1 Then
ActiveSheet.Shapes("Rectangle 1").Select

.............

end sub

Gracias

 

Link to post
Share on other sites

@Milton Cordova ¿Has visto el comentario de @Antoni ?. Usa el siguiente código
 

Private Sub Worksheet_Change(ByVal Target As Range)

ActiveSheet.Unprotect "X"

If Range("A1").DirectPrecedents = 1 Then

ActiveSheet.Shapes("Rectangle 1").Select
    Selection.Font.ColorIndex = 0
    ActiveSheet.Shapes("Rectangle 2").Select
    Selection.Font.ColorIndex = 0
    Range("C7").Select
    ActiveSheet.Shapes("Line 3").Select
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 64
    Selection.ShapeRange.Line.Visible = msoTrue
    
ActiveSheet.Protect "X"

ElseIf Range("A1").DirectPrecedents = 0 Then
ActiveSheet.Shapes("Rectangle 1").Select
    Selection.Font.ColorIndex = 2
    ActiveSheet.Shapes("Rectangle 2").Select
    Selection.Font.ColorIndex = 2
    Range("B14").Select
    ActiveSheet.Shapes("Line 3").Select
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 9
    Selection.ShapeRange.Line.Visible = msoTrue
    ActiveSheet.Protect "X"

End If

End Sub

 

Link to post
Share on other sites
Guest
This topic is now closed to further replies.

INFORMACIÓN BÁSICA SOBRE PROTECCIÓN DE DATOS

Responsable: Sergio Andrés Celemín

Finalidad: Moderar y responder comentarios de usuarios. Recuerda que la información que facilites es pública, y los datos que incluyas los leerá cualquier visitante de esta web, así como el avatar que poseas.

Legitimación: Consentimiento del interesado.

Destinatarios: Hetzner Online GmbH.

Derechos: Puedes ejercitar en cualquier momento tus derechos de acceso,
rectificación, supresión, oposición y demás derechos legalmente establecidos a
través del email sergio@ayudaexcel.com.

Información adicional: Encontrarás más información en la política de privacidad.




×
×
  • Create New...

Important Information

Privacy Policy