vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
Mails senden, abrufen und decodieren - ganz easy ;-)  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2024
 
zurück
Rubrik: Excel   |   VB-Versionen: VBA26.09.08
Einfache Methode zum Formelschutz in Excel-Tabellen

Es wird eine recht einfache Methode beschrieben, wie man mit VBA in Excel die Formeln einer Tabelle vor Überschreiben schützen kann, ohne den Blattschutz einstellen zu müssen. (Excel 2003/2007).

Autor:   Dietrich HerrmannBewertung:     [ Jetzt bewerten ]Views:  14.145 
ohne HomepageSystem:  Win2k, WinXP, Win7, Win8, Win10, Win11kein Beispielprojekt 

Ich hatte ein paar Methoden im Internet gefunden, um den oben genannten Zweck zu erreichen, habe aber dann lieber selbst einen Versuch es zu programmieren, gemacht. Die nachfolgenden Funktionen muss man in einem Modul speichern.

' benötigte Variablen
Public FormulaSelection As String
Public acAddress As String
Public lastacAddress As String
Public retFormula As String
' Range-Adressem die alle Zellen mit Formeln repräsentiert
Public Sub selFormulas( _
  Optional wRng As Boolean = False, _
  Optional wRange As Range = Nothing)
 
  acAddress = ""
  lastacAddress = ""
  Selection.SpecialCells(xlCellTypeFormulas, 23).Select
  FormulaSelection = Selection.Address
  If wRng Then FormulaSelection = FormulaSelection & wRange.Address
  Range(ActiveCell.Address).Select
End Sub

Der Code bewirkt für die aktive Tabelle, dass jede Formelzelle, auch wenn sie editiert wird (also irgendwelche Werte eingetragen werden), beim Wechsel in eine andere Zelle (beenden der Eingabe mit Enter etc.) immer wieder mit der vorher vorhandenen Formel 'bestückt' werden.

Public Sub secureFormula( _
  Sh As Worksheet, ByVal Trgt As Range)
 
  If Len(FormulaSelection) = 0 Or ActiveCell Is Nothing Then Exit Sub
  If Not (Application.Intersect(ActiveCell, _
    Sh.Range(FormulaSelection)) Is Nothing) Then ' ist Formelfeld gewählt?
 
    acAddress = ActiveCell.Address
    If Len(lastacAddress) = 0 Or lastacAddress <> acAddress Then
      f = Sh.Range(acAddress).Formula
      If Len(f) = 0 Or Len(lastacAddress) > 0 Then 
        Sh.Range(lastacAddress).Formula = retFormula
      End If
      lastacAddress = acAddress
      retFormula = ActiveCell.Formula
    Else
      If Len(retFormula) > 0 Then Sh.Range(acAddress).Formula = retFormula
    End If
  Else
    If Len(retFormula) > 0 And Len(lastacAddress) > 0 Then 
      Sh.Range(lastacAddress).Formula = retFormula
    End If
  End If
End Sub

Die Funktionen werden in der aktiven Tabelle in folgenden Ereignissen aufgerufen:

Private Sub Worksheet_Activate()
  selFormulas
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  secureFormula ActiveSheet, Range(Target.Address)
End Sub

That's it!
Dietrich