F2.30

(macro) Excel, proteger celdas

F2.40

(macro) Word, ordena dos o mas párrafos

F2.45

(macro) Casilla de verificación en Word

F2.50

(macro) Formularios Word. Desactivar tecla INTRO

F3.05

(macro) Macro para botón en formulario Access

Páginas:
(macro) Excel, proteger celdas

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







Sesión:
registrar en twiiter
Inicie sesión ...


Editores de contenidos

No es un Editor...



Títulos


Tweets aulapc.es:





 eduardo@aulapc.es Granada (España)