Thema Datum  Von Nutzer Rating
Antwort
04.12.2023 07:47:30 Mero
Solved
04.12.2023 09:05:50 Gast92278
NotSolved
04.12.2023 09:20:02 Gast16832
NotSolved
Blau Code für automatisches Sperren der Zellen
05.12.2023 15:47:51 Gast49310
NotSolved
05.12.2023 15:49:22 Gast80632
NotSolved
06.12.2023 06:51:46 ralf_b
NotSolved
07.12.2023 23:06:09 Gast8566
NotSolved
08.12.2023 07:05:59 ralf_b
NotSolved

Ansicht des Beitrags:
Von:
Gast49310
Datum:
05.12.2023 15:47:51
Views:
101
Rating: Antwort:
  Ja
Thema:
Code für automatisches Sperren der Zellen

Die erste lauffähige Version  ist fertig gestellt worden:

Damit der nachstehende VBA-Code funktioniert, müssen zwei Arbeitsmappen-Namenseinträge erstellt werden:

Transaktionen - Verweist auf die Tabelle inkl. Überschriften

TransaktionDaten - Verweist auf die Spalten B bis G in der Tabelle "Transaktionen"

Folgender VBA-Code muss in einem Modul gespeichert werden:

Option Explicit

Sub CheckCellProtect()
    Dim rngTab As Range, rngRow As Range
    Set rngTab = getTransaction()

    For Each rngRow In rngTab.Rows
        SetProtectRow rngRow, IsTableRowComplete(rngRow)
    Next
End Sub

Function getTransaction() As Range
    Set getTransaction = ActiveWorkbook.Names("Transaktionen").RefersToRange
End Function

Function getTransactionData() As Range
    Set getTransactionData = ActiveWorkbook.Names("TransaktionDaten").RefersToRange
End Function

Function IsTableRowComplete(rngRow As Range) As Boolean
    Dim rng As Range
    IsTableRowComplete = True
    For Each rng In rngRow.Cells
        If IsEmpty(rng) Then
            IsTableRowComplete = False
            Exit For
        End If
    Next
End Function

Sub SetProtectRow(rngRow As Range, Statuslocked As Boolean)
    Dim rng As Range
    ProtectSheet rngRow.Worksheet, False
    For Each rng In rngRow.Cells
        rng.Locked = Statuslocked
    Next
    ProtectSheet rngRow.Worksheet, True
End Sub

Sub ProtectSheet(sh As Worksheet, Protection As Boolean)
    If sh.ProtectContents = True And Protection = False Then
        sh.Unprotect Password:="DeinPasswort"
    ElseIf sh.ProtectContents = False And Protection = True Then
        sh.Protect Password:="DeinPasswort", UserInterfaceOnly:=True
    End If
End Sub

Function ColumnStorno(rng As Range) As Boolean
    Dim rngTab As Range
    Dim rngActive As Range
    Set rngTab = getTransaction()
    If Not Intersect(rng, rngTab) Is Nothing Then
        Set rngActive = ActiveCell
        If Not Intersect(rng.EntireRow, rngActive, GetStornoColumn) Is Nothing Then
            ColumnStorno = True
        End If
    End If
End Function

Function GetStornoColumn()
    Dim rngTab As Range, rngTitle As Range, rngStorno As Range
    Set rngTab = getTransaction()
    Set rngTitle = rngTab '.Row(1)
    Set rngStorno = rngTitle.Find(what:="Storno", LookIn:=xlValues, LookAt:=xlWhole)
    If Not rngStorno Is Nothing Then
        Set rngStorno = Intersect(rngStorno.EntireColumn, rngTab)
    End If
    Set GetStornoColumn = rngStorno
End Function

Folgender VBA-Code muss in der Tabelle gespeichert werden:

Option Explicit

Dim rngLastStorno As Range

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngTab As Range, rngTabData As Range, rng As Range
    Set rngTab = getTransaction
    Set rngTabData = getTransactionData
    If Not Intersect(Target, rngTab, rngTabData) Is Nothing Then
        Set rng = Intersect(rngTab, Target.EntireRow, rngTabData)
        If rng.Find(what:="", LookIn:=xlValues) Is Nothing Then
            If MsgBox(Prompt:="Wollen Sie diese Angaben endgültig übernehmen?", Buttons:=vbYesNo) = vbYes Then
                ProtectSheet rng.Worksheet, False
                rng.Locked = True
                ProtectSheet rng.Worksheet, True
            End If
        End If
    End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim rngRow As Range
    If Not rngLastStorno Is Nothing Then
        With rngLastStorno.Interior
            .Color = 16777215
        End With
        Set rngLastStorno = Nothing
    End If
    If ColumnStorno(Target) Then
        Set rngRow = Intersect(getTransaction, Target.EntireRow)
        With rngRow.Interior
            .Color = 255
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
        End With
        Set rngLastStorno = rngRow
    End If
End Sub

Als Passwort für den Blattschutz wird "MeinPasswort" verwendet.


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
04.12.2023 07:47:30 Mero
Solved
04.12.2023 09:05:50 Gast92278
NotSolved
04.12.2023 09:20:02 Gast16832
NotSolved
Blau Code für automatisches Sperren der Zellen
05.12.2023 15:47:51 Gast49310
NotSolved
05.12.2023 15:49:22 Gast80632
NotSolved
06.12.2023 06:51:46 ralf_b
NotSolved
07.12.2023 23:06:09 Gast8566
NotSolved
08.12.2023 07:05:59 ralf_b
NotSolved