vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#

https://www.vbarchiv.net
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:  Views:  14.154 
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



Anzeige

Kauftipp Unser Dauerbrenner!Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv  Vol.6

Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
- nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten
- Symbol-Galerie mit mehr als 3.200 Icons im modernen Look
Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m.
 
 
Copyright ©2000-2024 vb@rchiv Dieter OtterAlle Rechte vorbehalten.


Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.