Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1672to1676
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Frage an Uwe

Frage an Uwe
30.01.2019 08:19:31
Philip
Hallo Uwe, ich habe nocheinmal eine Frage an dich. Du hast mir ja mit dem folgendem Code geholfen

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

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Frage an Uwe
30.01.2019 09:04:58
UweD
Hallo
Dieses Makro liegt im Code-Bereich der jeweiligen Tabelle selbst.
Er wird auch nur ausgelöst, wenn sich auf Diesem Blatt in Spalte 2 was ändert
Soll das in einem anderen (oder mehreren) Blatt geschehen, musst du das Makro verschieben (kopieren)
LG UweD
AW: Frage an Uwe
30.01.2019 09:22:34
Philip
Hallo Uwe,
das habe ich gemacht aber jetzt dieses Problem:
In Mech steht in Spalte 2 der Name Test 1
In EBT steht der Name Test 2
zu beiden Namen gibt es ja nun ein Tabellenblatt
Lösche ich jetzt in Mech den Namen Test1 so wird auch die Tabelle Test2 wo der Name in Ebt steht gelöscht.
Der Code kontrolliert ja nur Spalte 2 aus dem Blatt Mech(bzw des aktiven Blattes). Sieht folglich ga nicht das bei EBT auch ein Name steht und er Test2 somit nicht löschen soll.
Anzeige
lad nochmal eine Musterdatei hoch.
30.01.2019 10:20:16
UweD
AW: lad nochmal eine Musterdatei hoch.
30.01.2019 13:58:09
UweD
Hallo nochmal
dann so..
In ein Normales Modul muss das hier

Sub BlattWeg(TabName As String, Zeile As Long, Spalte As Integer)
    Dim Bl, FixArr(), NieArr()
    FixArr = Array("MECH", "EBT", "WM", "IM") 'in diesen Blätter überprüfen 
    NieArr = Array("MECH", "EBT", "WM", "IM", "MusterMechatronik", "MusterEBT") 'Diese Blätter nie löschen 
    
    For Each Bl In ThisWorkbook.Sheets
        If InStr(Join(NieArr, "# "), Bl.Name & "# ") > 0 Then
           'Mach nichts 
        Else
            For Each Blatt In FixArr
                If WorksheetFunction.CountIf(Sheets(Blatt).Columns(Spalte), TabName) = 0 Then
                    'Blattname nicht vorhanden 
                    TMP = False
                Else
                    'Blatt noch in Spalte 
                    TMP = True
                    Exit For 'Weitere Prüfung kann dann entfallen 
                End If
            Next Blatt
            
            If Not TMP Then
                'Blatt löschen, da nirgendwo mehr in Spalte enthalten 
                Application.DisplayAlerts = False
                Sheets(TabName).Delete
                Application.DisplayAlerts = True
            End If
            
            'gesamte Zeile löschen 
             Application.EnableEvents = False
             ActiveSheet.Rows(Zeile).Delete xlUp
             Application.EnableEvents = True
                
                
            'Restliche Prüfung kann entfallen 
            Exit For
        End If
    Next

End Sub

In den Codebereich jeden Blattes, das überwacht werden soll das hier
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
                 
             
            If JaNein = vbYes Then
                'Prüfung ob Blatt gelöscht werden kann 
                Call BlattWeg(Vorher, Target.Row, 2)
            End If
        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
LG UweD
Anzeige
AW: lad nochmal eine Musterdatei hoch.
30.01.2019 14:48:31
Philip
Codebereich jedes Blattes meinst du auf der tabelle des blattes rechtsklick code anzeigen und dort hinein?
Wo quasi das andere vorher drin war?
Was meinst du mit normales modul?
AW: lad nochmal eine Musterdatei hoch.
30.01.2019 14:57:13
UweD
Hallo
Codebereich jedes Blattes meinst du auf der tabelle des blattes rechtsklick code anzeigen und dort hinein?
Wo quasi das andere vorher drin war?

Ja genau

Was meinst du mit normales modul?

Hier...
Userbild
LG UweD
AW: lad nochmal eine Musterdatei hoch.
30.01.2019 14:52:01
Philip
Sorry ich hab es. Modul erstellen und dort einfach rein.
Perfekt vielen Dank :)
Anzeige
Prima! Danke für die Rückmeldung. owT
30.01.2019 14:58:32
UweD

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige