Frage an Uwe
30.01.2019 08:19:31
Philip
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Fehler
Dim Blatt, SP As Integer, TMP As Variant, Neu
Dim JaNein, Vorher As String
'*** Stammdaten Anfang
SP = 2 'Überwachte Spalte
'*** Stammdaten Ende
If Not Intersect(Columns(SP), Target) Is Nothing Then
If Target.Count = 1 Then
Application.ScreenUpdating = False
'prüfen ob Zelle vorher gefüllt war und jetzt leer ist
With Application
.EnableEvents = False
.Undo
Vorher = Target.Value
.Undo
If Vorher "" And Target.Value = "" Then
'Löschen bestätigen
JaNein = MsgBox("Wirklich löchen?", vbYesNo + vbQuestion, "Eintrag löschen") _
_
If JaNein = vbNo Then
.Undo
.EnableEvents = True
Exit Sub
End If
End If
.EnableEvents = True
End With
'Prüfung ob Blatt gelöscht werden kann
For Each Blatt In ThisWorkbook.Sheets
Select Case Blatt.Name
Case "MECH", "MAF", "EBT", "WM", "IM", "MusterMechatronik", "MusterEBT", " _
_
MusterIM", "MusterWM", "MusterMAF", "Deckblatt", "Ausbilder", "Praktikanten Gewerblich", " _
aktive Betriebsaufträge", "Übersicht", "Unterweisungsinhalt"
'Mach nichts
Case Else
If WorksheetFunction.CountIf(Columns(SP), Blatt.Name) = 0 Then
'Blattname nicht vorhanden
Application.DisplayAlerts = False
Blatt.Delete
Application.DisplayAlerts = True
'gesamte Zeile löschen
Application.EnableEvents = False
Rows(Target.Row).Delete xlUp
Application.EnableEvents = True
End If
End Select
Next
End If
End If
'*** Fehlerbehandlung
Err.Clear
Fehler:
Application.EnableEvents = True
Application.DisplayAlerts = True
If Err.Number 0 Then MsgBox "Fehler: " & _
Err.Number & vbLf & Err.Description: Err.Clear
End Sub
Wie muss dieser geschrieben werden damit er die Spalte 2 in den Arbeitsblättern MECH, EBt , MAF und WM kontrolliert?
Derzeit sucht er den Namen ja nur in dem aktiven Blatt. Folglich löscht er mir Tabellen die er nicht löschen sollte. Bin dir wirklich dankbar für deine Hilfe