(macro) Excel, proteger celdas

Páginas:

        1  2   3   4   5   6   7

La siguiente macro crea un rango protegido de celdas en las que sólo se puede escribir nombres o frases de texto. Una vez que se aplica o ejecuta la macro queda un rango contiguo o discontiguo de celdas con formato protegido. Se pueden añadir nuevos rangos seleccionando y ejecutando la macro para dibujar cualquier rango. Si la celda/s del rango seleccionado ya tiene formato protegido para texto entoces se borra y se convierten en celdas normales. La macro actúa como conutador: si ejecuta sobre celdas normales se aplica el formato; si se ejecuta sobre celdas que ya tienen formato se convierten en celdas normales...

¿Cómo se comportan las celdas con rango protegido?
1) Si introducimos la expresión B4 en D4 se admite.
2) B5 se admite en una celda normal, pero no en D5
3) La expresión correcta =10+5 produce 15 en una celda normal. No se admite en el rango protegido.
4) =SUMA(D20;D22) produce 3200000 en celda normal. No se admite en rango...
5) =A19+B19 produce un error #¡VALOR! en celda normal, pero no se muestra en rango.
6) =djlksdf... produce error #¿NOMBRE?. Se elimina del rango protegido...
7) =A19 produce Amorós en celda normal. Se admite en rango protegido...
8) =A19&" "&D19 produce Amorós Soledad y se admite en rango...
9) =A19&" "&D19 produce Amorós Soledad y se admite en rango...
10) =D20&" "&D20 produce Andela Daniel25 que se admite en celda norma, pero no en rango...
11) 12345 se admite en celda normal, pero no en rango...
12) )(!!!!Ana produce )(!!!!Ana, pero no se admite en rango...
13) No se admite 897-22-333...
14) No se admite =C19...

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

La función pública patron(Optional referencia, Optional ultima) devuelve 1 o 2 según el valor de la referencia cumpla con la expresión regular ^A-Za-záéíóúÁÉÍÓÚ es decir, letras minúsculas, mayúsculas y acentos. Si la celda referenciada contiene caracteres distintos devuelve 2...

Public ban As Integer
Public mirango As Range


Public Function patron(Optional referencia, Optional ultima)
 Dim objRegex As VBScript_RegExp_55.RegExp
 Dim colMatch As VBScript_RegExp_55.MatchCollection
 Dim vbsMatch As VBScript_RegExp_55.Match
 Dim colSubMatch As VBScript_RegExp_55.SubMatches
 Dim sMatchString As String
 Dim i, num, numT As Integer
 Set objRegex = New VBScript_RegExp_55.RegExp
On Error GoTo ControlErrores
 objRegex.IgnoreCase = True
 objRegex.Global = True
 objRegex.Pattern = "[^A-Za-záéíóúÁÉÍÓÚ ]+"
 Set colMatch = objRegex.Execute(referencia)
 numT = colMatch.Count
 objRegex.Pattern = "[A-Za-záéíóúÁÉÍÓÚ ]+"
 Set colMatch = objRegex.Execute(referencia)
 num = colMatch.Count
 If numT = 0 And num >= 0 Then
  patron = 1
 Else
  patron = 2
 End If
 Exit Function
ControlErrores:
 Select Case Err.Number
  Case 13
  MsgBox ("sal por 13 Controerror ")
  Worksheets(ActiveSheet.Name).Range(ultima).Value = ""
  Exit Function
  Case 9
 End Select
End Function

Subprocedimiento inicia()...
.
.
.
.
.
.


Sub inicia()
 Application.EnableEvents = False
 Dim unaref, unerangos, unesec As Range
 Dim lahoja, lahojasec, lahojasecA As String
 Dim i, lafil, ban, borrador As Integer
 Dim encontrada As Boolean
 lahoja = ActiveSheet.Name
 Set mirango = Range(ActiveCell,ActiveCell.Cells(Selection.Rows.Count,selection.Columns.Count))
 dosceldas = mirango.Address(RowAbsolute:=False, ColumnAbsolute:=False)
 For i = 1 To Sheets.Count
  If Sheets(i).Name = "sec" & ActiveSheet.Name Then
   ban = 1
  End If
 Next i
 If ban <> 1 Then
  Range(dosceldas).Name = ActiveSheet.Name
  Set NewSheet = Sheets.Add(Type:=xlWorksheet, After:=Worksheets(Worksheets.Count))
  NewSheet.Name = "sec" & lahoja
  Range(dosceldas).Name = ActiveSheet.Name
  Sheets.Item(Mid(ActiveSheet.Name, 4)).Activate
 Else
  Set unerangos = Union(Range(ActiveSheet.Name), mirango)
  unerangos.Name = ActiveSheet.Name
  lahojasecA = Replace(unerangos.Name, "Hoja", "secHoja")
  ActiveWorkbook.Names.Item("sec" & ActiveSheet.Name).RefersTo = lahojasecA
 End If
 If borrador = 0 Then
  mirango.Interior.Color = RGB(250, 250, 250)
  mirango.Borders.Color = RGB(105, 105, 105)
  For Each ciclo In Sheets.Item("sec" & ActiveSheet.Name).Range("sec" & ActiveSheet.Name).Cells
   ciclo.Value = "=patron(" & lahoja & "!" & ciclo.Address(RowAbsolute:=True, ColumnAbsolute:=True) & ")"
  Next
 Else
  mirango.Interior.Color = RGB(255, 252, 255)
  mirango.Borders.Color = RGB(208, 215, 229)
   For Each ciclo In Sheets.Item(lahoja).Range(dosceldas).Cells
    ciclo.Value = " "
   Next
   For Each ciclo In Sheets.Item("sec" & ActiveSheet.Name).Range(dosceldas).Cells
    ciclo.Value = ""
   Next
 End If
 Application.EnableEvents = True
End Sub

---
---

Subprocemiento ActivaEV() es aconsejable tenerlo como una macro independiente para controlar si está permitido arrastrar y soltar con CellDragAndDro y si los eventos están habilitados o no con EnableEvents ya que afectan a la aplicación misma en al que estamos...
.
.
.
.
.


Sub ActivaEV()
  Application.CellDragAndDrop = True
  Application.EnableEvents = True
End Sub

Sub kalugi()
 Dim X, interBorra, unaref, unerangosA, unerangos, copiamirango, unesec As Range
 Dim donlimpio, donlimpioA, lahoja, paraReC, paraReR, finalRe As String
 Dim ban, MyPos, encontrado, numC, numR As Integer
 Application.DisplayInsertOptions = True
 Application.CutCopyMode = xlCopy
 Application.CellDragAndDrop = False
 lahoja = ActiveSheet.Name
 Set mirango = Range(ActiveCell, ActiveCell.Cells(Selection.Rows.Count, Selection.Columns.Count))
 copiamirango = mirango
 dosceldas = mirango.Address(RowAbsolute:=False, ColumnAbsolute:=False)
 For i = 1 To Names.Count
  If Names.Item(i).Name = "A" & ActiveSheet.Name Then
   If Names.Item(i).Value = "=#N/A" Then
    Names.Item(i).Delete
    Names.Item("b" & ActiveSheet.Name).Delete
   Else
    MyPos = InStr(Names.Item(i).Name, "#¡REF!")
   End If
   ban = 1
  End If
 Next i
 If ban <> 1 Then
  Range(mirango.Address).Name = "A" & ActiveSheet.Name
  Range(mirango.Address).Name = "B" & ActiveSheet.Name
  Range(mirango.Address).Name = "K" & ActiveSheet.Name
  ActiveWorkbook.Names.Item("K" & ActiveSheet.Name).RefersTo = "=" & ActiveSheet.Name & "!" & "$A$1"
  ActiveWorkbook.Names.Item("A" & ActiveSheet.Name).RefersTo = mirango
  ActiveWorkbook.Names.Item("B" & ActiveSheet.Name).RefersTo = mirango
 Else
  Set interBorra = Application.Intersect(Range(Names("A" & ActiveSheet.Name).Name), Range(mirango.Address))
  If interBorra Is Nothing Then
   Set unerangos = Union(Range("A" & ActiveSheet.Name), mirango)
   ActiveWorkbook.Names.Item("A" & ActiveSheet.Name).RefersTo = unerangos
   ActiveWorkbook.Names.Item("B" & ActiveSheet.Name).RefersTo = unerangos
  Else
   For Each c In Worksheets(ActiveSheet.Name).Range("A" & ActiveSheet.Name).Cells
    For Each kk In Worksheets(ActiveSheet.Name).Range(interBorra.Address).Cells
     If kk.Address = c.Address Then
      encontrado = 1
      Range(c.Address).Interior.Color = RGB(255, 252, 255)
      Range(c.Address).Borders.Color = RGB(208, 215, 229)
      Range("$A$1").Interior.Color = RGB(255, 252, 255)
      Range("$A$1").Borders.Color = RGB(208, 215, 229)
      Exit For
     Else
      encontrado = 0
     End If
   Next
   If encontrado <> 1 Then
    Set unerangos = Union(Range("K" & ActiveSheet.Name), Range(c.Address))
    ActiveWorkbook.Names.Item("K" & ActiveSheet.Name).RefersTo = unerangos
   End If
  Next
  X = ActiveWorkbook.Names.Item("K" & ActiveSheet.Name).RefersTo
  X = Replace(X, ActiveSheet.Name & "!$A$1,", "", 1, 1)
  ActiveWorkbook.Names.Item("A" & ActiveSheet.Name).RefersTo = X
  If ActiveWorkbook.Names.Item("A" & ActiveSheet.Name).Value = "=" & ActiveSheet.Name & "!#¡REF!" Then
   Names.Item("A" & ActiveSheet.Name).Delete
   Names.Item("B" & ActiveSheet.Name).Delete
   Names.Item("K" & ActiveSheet.Name).Delete
  Exit Sub
 End If
 If ActiveWorkbook.Names.Item("A" & ActiveSheet.Name).RefersTo = "=" & ActiveSheet.Name & "!$A$1" Then
  Names.Item("A" & ActiveSheet.Name).Delete
  Names.Item("B" & ActiveSheet.Name).Delete
  Names.Item("K" & ActiveSheet.Name).Delete
  Exit Sub
 End If
 Names.Item("K" & ActiveSheet.Name).Delete
 Range(mirango.Address).Name = "K" & ActiveSheet.Name
 ActiveWorkbook.Names.Item("K" & ActiveSheet.Name).RefersTo = "=" & ActiveSheet.Name & "!" & "$A$1"
 End If
 For i = 1 To Sheets.Count
  If Sheets(i).Name = ActiveSheet.Name Then
   For Each RR In Worksheets(ActiveSheet.Name).Range("A" & ActiveSheet.Name).Cells
    VueltaPat = patron(RR.Value)
    If VueltaPat = 1 Then
    End If
    If VueltaPat = 2 Then
     Sheets.Item(ActiveSheet.Name).Range(RR.Address).Cells = ""
    End If
    If VueltaPat = 0 Then
     Sheets.Item(ActiveSheet.Name).Range(RR.Address).Cells = ""
    End If
   Next
  End If
 Next i
 End If
End Sub

Enventos del Libro:
Workbook_SheetActivate(ByVal Sh As Object)
Workbook_SheetDeactivate(ByVal Sh As Object)
Workbook_SheetCalculate(ByVal Sh As Object)
Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)


Objetos en ThisWorkbook

Option Explicit Public mirango, unesec As Range Public dosceldas As String

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
 Application.EnableEvents = False
 Application.EnableEvents = True
End Sub

Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
 Application.EnableEvents = False
 Application.EnableEvents = True
End Sub

Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
 Application.EnableEvents = False
 Application.EnableEvents = True
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
 Application.EnableEvents = False
 Dim interSele As Range
 Dim eleven As Worksheet
 Dim i As Integer
 On Error GoTo 0
 On Error Resume Next
 For i = 1 To Names.Count
  If Names.Item(i).Name = "A" & ActiveSheet.Name Then
   Set interSele = Application.Intersect(Range(Names("A"&ActiveSheet.Name).Name),Range(Target.Address))
   If interSele Is Nothing Then
    Range(Names("A" & ActiveSheet.Name).Name).Interior.Color = RGB(255, 252, 255)
    Range(Names("A" & ActiveSheet.Name).Name).Borders.Color = RGB(208, 215, 229)
    interSele.Interior.Color = RGB(255, 252, 255)
    interSele.Borders.Color = RGB(208, 215, 229)
    interSele.Interior.Color = RGB(250, 250, 250)
    interSele.Borders.Color = RGB(105, 105, 105)
   Else
    Range(Names("A" & ActiveSheet.Name).Name).Interior.Color = RGB(250, 250, 250)
    Range(Names("A" & ActiveSheet.Name).Name).Borders.Color = RGB(105, 105, 105)
    interSele.Interior.Color = RGB(250, 250, 250)
    interSele.Borders.Color = RGB(105, 105, 105)
    Range(interSele.Address).Select
   End If
   Exit For
  End If
 Next i
 Application.EnableEvents = True
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
 Application.EnableEvents = False
 Dim inter, RR As Range
 Dim MyPos, VueltaPat, i As Integer
 Dim otra As String
 On Error GoTo 0
 On Error Resume Next sigue para
 Set inter = Application.Intersect(Range(Names("A" & ActiveSheet.Name).Name), Range(Target.Address))
 If inter Is Nothing Then
  For i = 1 To Sheets.Count
   If Sheets(i).Name = ActiveSheet.Name Then
    otra = Target.Address
    For Each RR In Worksheets(ActiveSheet.Name).Range("A" & ActiveSheet.Name).Cells
     VueltaPat = patron(RR.Value, otra)
     If VueltaPat = 1 Then
     End If
     If VueltaPat = 2 Then
      Sheets.Item(ActiveSheet.Name).Range(RR.Address).Cells = ""
     End If
     If VueltaPat = 0 Then
      Sheets.Item(ActiveSheet.Name).Range(RR.Address).Cells = ""
     End If
    Next
   End If
  Next i
 Else
 For i = 1 To Sheets.Count
  If Sheets(i).Name = ActiveSheet.Name Then
   otra = Target.Address
   For Each RR In Worksheets(ActiveSheet.Name).Range("A" & ActiveSheet.Name).Cells
    VueltaPat = patron(RR.Value, otra)
    If VueltaPat = 1 Then
    End If
    If VueltaPat = 2 Then
     Sheets.Item(ActiveSheet.Name).Range(RR.Address).Cells = ""
    End If
    If VueltaPat = 0 Then
     Sheets.Item(ActiveSheet.Name).Range(RR.Address).Cells = ""
    End If
   Next
  End If
 Next i
 Worksheets(ActiveSheet.Name).Calculate
 Range("A" & ActiveSheet.Name).Calculate
 End If
 Application.EnableEvents = True
End Sub

Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
 Dim intermous As Range
 Dim i As Integer
 For i = 1 To Names.Count
  If Names.Item(i).Name = "A" & ActiveSheet.Name Then
   Set intermous = Application.Intersect(Range(Names("A" & ActiveSheet.Name).Name),Range(Target.Address))
  End If
 Next i
 If intermous Is Nothing Then
 Else
  Cancel = True
 End If
 If Target.Address = "$A:$A" Then
  Cancel = True
 End If
End Sub

(macro) Excel, proteger celdas