Al usar la macro desproteje la hoja
Buenos días
Al usar esta macro:
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
' Columnas en MAYUSCULAS
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
If Not Application.Intersect(Target, Range("F7:F2000")) Is Nothing Then
Target.Value = UCase(Target)
End If
La hoja no queda protegida y es lo que me interesaría.
Un saludo
1 respuesta
Respuesta de Dante Amor
1
Si quieres que se proteja con password, cambia "abc" por la palabra que desees.
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
' Columnas en MAYUSCULAS
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
pwd = "abc"
ActiveSheet.Unprotect pwd
If Not Application.Intersect(Target, Range("F7:F2000")) Is Nothing Then
Target.Value = UCase(Target)
End If
ActiveSheet.Protect "abc", False, True, False, True, True, _
True, True, True, True, True, True, True, True, True
ActiveSheet.EnableSelection = xlNoRestrictions
'
Te he mandado un archivo a tu correo.
No me funcionan las soluciones dadas
Un saludo
No estaban los protect en los lugares correctos dentro de la macro. Ya los corregí
Private Sub Worksheet_Activate()
ActiveSheet.Protect Password:="1"
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
' AGREGAR FECHA EN UNA COLUMNA
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
If Target.Column = 5 Then
If Cells(Target.Row, "B") = "" Then
ActiveSheet.Unprotect Password:="1"
Cells(Target.Row, "B") = Date
ActiveSheet.Protect Password:="1"
End If
End If
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
' Columnas en MAYUSCULAS
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
If Not Application.Intersect(Target, Range("F7:F2000")) Is Nothing Then
ActiveSheet.Unprotect Password:="1"
Target.Value = UCase(Target)
ActiveSheet.Protect Password:="1"
End If
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
' F O T O S
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
If Not Intersect(Target, Columns("E")) Is Nothing Then
If Target.Count > 1 Then Exit Sub
ActiveSheet.Unprotect Password:="1"
If Target <> "" Then
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
' AGREGAR FOTOS
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
'ruta = "C:\trabajo\Fotos\"
Ruta = "G:\Factura\Fotos\"
imagen = Dir(Ruta & Target.Value & ".*")
If imagen <> "" Then
imgactual = Cells(Target.Row, "D")
If imgactual <> "" Then
ActiveSheet.Shapes(imgactual).Delete
End If
Set etiqueta = ActiveSheet.Pictures.Insert(Ruta & imagen)
With etiqueta
.ShapeRange.LockAspectRatio = msoFalse
.Left = Cells(Target.Row, "D").Left
.Top = Cells(Target.Row, "D").Top
.Height = Range(Cells(Target.Row, "D"), Cells(Target.Row + 5, "D")).Height 'alto imagen
.Width = Cells(Target.Row, "D").Width 'ancho imagen
End With
imgactiva = etiqueta.Name
Cells(Target.Row, "D") = imgactiva
Else
MsgBox "La referencia no tiene foto", vbExclamation
End If
Else
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
' Eliminar FOTOS
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
On Error Resume Next
If Target.Count > 1 Then Exit Sub
imgactual = Cells(Target.Row, "D")
If imgactual <> "" Then
ActiveSheet.Shapes(imgactual).Delete
End If
Cells(Target.Row, "D") = ""
Cells(Target.Row, "B") = ""
End If
ActiveSheet.Protect Password:="1"
End If
End Sub
