AW: Tabelle löschen wenn Name in Zeile gelöscht wird
23.01.2019 09:28:01
UweD
Wie soll denn das Löschen ausgelöst werden?
Ich hatte es so vorgesehen, wenn in eine Spalte A (jetzt bei dir gewünscht B) ein Eintrag entfernt wird...
Da das nicht so ohne Weiteres geht, der Umweg...
Ich hatte deshalb bei JEDER Änderung in der Spalte Alle Tabellenblätter geprüft, ob deren Name in DER Spalte vorkommt. Wenn nicht, dann weg damit.
Wenn du das Neuanlegen sowieso über die Userform machst, kann der Part aus meinem Code ja raus.
So wie ich das sehe, sollen ja weitere Blätter ausgenommen werden.
Das abgeänderte Makro (muss in den Bereich des Tabellenblattes).
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Fehler
Dim Blatt, SP As Integer, TMP As Variant, Neu
'*** 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üfung ob gelöscht werden kann
For Each Blatt In ThisWorkbook.Sheets
Select Case Blatt.Name
Case "MECH", "MAF", "EBT", "WM", "IM", "MusterMechatronik"
'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
Aber dein Code der Userform muss auch noch abgeändert werden
Private Sub Button_Eingabe_Click()
On Error GoTo Fehler
'Vermeiden von Doppelt benanntem Nachnamen (MECH)
Dim Bereich As Range
Dim Name As String
Name = Bedienfeld.TextBox_Nachname
Dim Letzte As Long
If [D65536] = "" Then
Letzte = [D65536].End(xlUp).Row
Else
Letzte = 65536
End If
Set Bereich = Sheets("MECH").Range("b8:B" & Letzte) _
.Find(Bedienfeld.TextBox_Nachname)
If Bereich Is Nothing Then
' Keine weiteren AktionenAktion
Else
If Bedienfeld.TextBox_Nachname.Value = "" Then
MsgBox ("Bitte Nachname eingeben")
Else
MsgBox "Nachname '" & Name & "' prüfen! Nachname schon vorhanden. Bitte durchnummerieren z.B'" & Name & " 1'"
Bedienfeld.TextBox_Nachname = ""
End If
End If
If Bedienfeld.TextBox_Nachname.Value = "" Then
'Keine Aktion
Else
If Bedienfeld.TextBox_Vorname.Value = "" Then
MsgBox ("Bitte Vornamen eingeben")
Else
If Bedienfeld.TextBox_Personalnummer.Value = "" Then
MsgBox ("Bitte Personalnummer eingeben")
Else
Dim letzteZeile As Long
letzteZeile = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
'Events temporär ausschalten
Application.EnableEvents = False
Rows(letzteZeile + 1).Insert 'Zeile einfügen
Rows(letzteZeile).Copy Cells(letzteZeile + 1, 1) 'Zeile kopieren
'Daten aus dem Textfeld schreiben
ActiveSheet.Cells(letzteZeile + 1, "B").Value = Bedienfeld.TextBox_Nachname.Value
ActiveSheet.Cells(letzteZeile + 1, "C").Value = Bedienfeld.TextBox_Vorname.Value
ActiveSheet.Cells(letzteZeile + 1, "D").Value = Bedienfeld.TextBox_Personalnummer.Value
'Events temporär ausschalten
Application.EnableEvents = True
'kopiere MusterBlatt und benenne es nach eingabe in Textboxen
ActiveWorkbook.Worksheets("MusterMechatronik").Copy after:=ActiveWorkbook.Sheets(Sheets.Count)
ActiveSheet.Name = Bedienfeld.TextBox_Nachname
'Wieder zur Ausgangsansicht
Sheets("MECH").Select 'Für jede Berufgruppe ändern
Range("A1").Select
'Erzeugen von Hyperlink
Dim Tabelle As String
Dim r As Long
r = 8
With ThisWorkbook.ActiveSheet 'Worksheet für Jede Berufsgruppe ändern
Do While .Range("B" & r) <> ""
Tabelle = .Range("B" & r).Value
.Hyperlinks.Add Anchor:=.Range("B" & r), _
Address:="", SubAddress:="'" & Tabelle & "'!C5", _
TextToDisplay:=Tabelle
r = r + 1
Loop
End With
Load Bedienfeld
Bedienfeld.TextBox_Nachname = ""
Bedienfeld.TextBox_Vorname = ""
Bedienfeld.TextBox_Personalnummer = ""
End If
End If
End If
'*** Fehlerbehandlung
Err.Clear
Fehler:
Application.EnableEvents = True
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & vbLf & Err.Description: Err.Clear
End Sub
Private Sub Button_Zurück_Click()
'Eingabefenster schließen
Unload Bedienfeld
End Sub
LG UweD