Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1000to1004
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

Makro zum Löschen von Tabellenblätterm

Makro zum Löschen von Tabellenblätterm
22.08.2008 12:38:00
Tabellenblätterm
Hallo, ich wollte fragen ob es möglich ist mit Hilfe eines VBAs Tabellenblätter nach bestimmten Gesichtspunkten zu löschen.
Folge Ausgangslage:
Ich habe eine Excel mit vielen Tabellenblättern.
Auf Blatt "Gesamt" werden Daten erfasst.
Auf diesem Blatt werden in Spalte K ab K2 Namen geschrieben.
Wenn ich einen neuen Namen dazuschreibe wird per Makro ein neues Tabellenblatt erstellt, was den Namen des neuen Namen trägt.
Jetzt würde ich gerne, dass wenn ich einen Namen aus der Liste in K Lösche, dass per Makro automatisch das entsprechende Tabellenblatt auch gleich gelöscht wird, sonst bläht sich die Datei immer mehr auf.
Das Makro müsste also die Namen mit denen der Tabellenblätter vergleichen und wenn er ein Tabellenblatt findet was nicht in der Liste steht, dann soll er es löschen, außer bestimmten Tabellenblättern, die ich vorher festlegen möchte. Ich lade mal eine Beispiel-Datei hoch, damit es verdeutlicht wird.
Danke schon mal für die Hilfe.
https://www.herber.de/bbs/user/54816.zip
Gruß Oblivion

10
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Automatisch Tabellenblätter löschen!
22.08.2008 13:25:10
Backowe
Hi,
VBA-Code:
Option Explicit
Public AlterWert As String
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("K2:K" & Cells(Rows.Count, "K").End(xlUp).Row)) Is Nothing And Target.Count = 1 Then _
  AlterWert = Target.Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
If Not Intersect(Target, Range("K2:K" & Cells(Rows.Count, "K").End(xlUp).Row)) Is Nothing And _
  Target.Count = 1 And Target = "" Then
  For Each ws In Worksheets
    If ws.Name = AlterWert Then
      Application.DisplayAlerts = False
      ws.Delete
      Application.DisplayAlerts = True
    End If
  Next
End If
End Sub
Gruß Jürgen

Anzeige
AW: Automatisch Tabellenblätter löschen!
23.08.2008 18:48:00
oblivion
Hallo, wollte dein Makro ausprobieren, aber ich bekam eine Fehlermeldung. Ich habe es in das Blatt "Gesamt" im Makroeditor kopiert. Dann habe ich es in "DieseArbeitsmappe" kopiert und da ist nichts passiert. Wenn ich den Code richtig interpretiere würde er mir jedesmal wenn ich die Datei starte eine Meldung anzeigen und Fragen ob er ein bestimmtes Tabellenblatt löschen kann. Oder irre ich mich da? Ich lade noch mal die Datei hoch, diesmal die Vollständige mit allen Tabellenblättern aber ohne persönlichen Daten.
Danke für die Hilfe.
Gruß Oblivion
https://www.herber.de/bbs/user/54843.zip

Anzeige
AW: Automatisch Tabellenblätter löschen!
23.08.2008 19:36:00
Backowe
Hi,
ich habe Dir ein Beispiel erstellt, damit sollten alle Klarheiten beseitigt sein! ;o)
https://www.herber.de/bbs/user/54849.xls
Gruß Jürgen

AW: Automatisch Tabellenblätter löschen!
23.08.2008 20:50:36
oblivion
Hallo, ich habe deinen Code in meine Daetei in Tabelle kopiert, in welcher auch die Namen stehen sollen. Wenn ich jetzt aber einen Namen eingeben will in der Spalte K, dann kommt eine Fehlermeldung die lautet: Fehler beim Kompilieren: Mehr deutiger Name: Worksheet_Change.
Gibts dafür eine Lösung?
Danke für die Hilfe.
Gruß Oblivion

Einfach in das bestehende Worksheet_Change ...
23.08.2008 21:17:36
Backowe
Hi,
... einbauen. Achso der Passwortschutz auf einem VBA-Projekt ist lächerlich, dauert nur ca. 60 Sekunden!
VBA-Code:
Option Explicit
Public AlterWert As String
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("K2:K" & Cells(Rows.Count, "K").End(xlUp).Row)) Is Nothing And Target.Count = 1 Then _
  AlterWert = Target.Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
   Dim Tab2 As Range, rowOffset As Long, strAdress As String
   Dim B As Long, A As Long, C As Long
   Dim ws As Worksheet
   If Not Intersect(Target, Range("B3")) Is Nothing Then
      With Application
         .EnableEvents = False
         .ScreenUpdating = False
      End With
      On Error GoTo Fehler1:
      With Tabelle2
         rowOffset = .Rows(2).Find(What:=Range("B3"), LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False).Column - 3
         Range("B5:B" & Rows.Count).ClearContents
         strAdress = .Range(.Cells(4, rowOffset), _
            .Cells(56, rowOffset)).Address
         .Range(strAdress).Copy Range("B5")
         Range("E5:G" & Rows.Count).ClearContents
         strAdress = .Range(.Cells(4, rowOffset + 1), _
            .Cells(56, rowOffset + 5)).Address
            .Range(strAdress).Copy Range("C5")
      End With
   ElseIf Not Intersect(Target, Columns(11)) Is Nothing Then
      ArztAnlegen Intersect(Target, Columns(11))
      Me.Activate
   End If
Fehler1:
   AnzeigeAn
   If Err.Number <> 0 Then
      MsgBox Err.Description, vbCritical, "Fehler beim Lesen!"
      Exit Sub
   End If
   On Error GoTo Fehler:
    If Selection.Count > 1 Then
      For C = 1 To Selection.Count
         If Intersect(Selection(C), Range("E5:G56", "B5:B56")) Is Nothing Then _
            Exit Sub
         AnzeigeAn
         B = Tabelle2.Rows(2).Find(What:=Range("B3"), LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False).Column - 2
         For A = 0 To 5
            If A <> 3 Then
               If A = 5 Then
                  Tabelle2.Cells(Selection(C).Row - 1, B - 1) = _
                     Cells(Selection(C).Row, 2).Value
               Else
                  Tabelle2.Cells(Selection(C).Row - 1, B + A).Value = _
                     Cells(Selection(C).Row, 3 + A).Value
               End If
            End If
         Next A
      Next C
   Else
      If Intersect(Target, Range("E5:G56", "B5:B56")) Is Nothing Then Exit Sub
      AnzeigeAn
      B = Tabelle2.Rows(2).Find(What:=Range("B3"), LookIn:=xlFormulas, _
         LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
         MatchCase:=False, SearchFormat:=False).Column - 2
      For A = 0 To 5
         If A <> 3 Then
            If A = 5 Then
               Tabelle2.Cells(Target.Row - 1, B - 1) = Cells(Target.Row, 2).Value
            Else
               Debug.Print Cells(Target.Row, 3 + A)
               Tabelle2.Cells(Target.Row - 1, B + A).Value = _
                  Cells(Target.Row, 3 + A).Value
            End If
         End If
      Next A
   End If
Fehler:
   AnzeigeAn
   If Err.Number <> 0 Then MsgBox Err.Description, vbCritical, _
      "Fehler beim schreiben!"
If Not Intersect(Target, Range("K2:K" & Cells(Rows.Count, "K").End(xlUp).Row)) Is Nothing And _
  Target.Count = 1 And Target = "" Then
  For Each ws In Worksheets
    If ws.Name = AlterWert Then
      Application.DisplayAlerts = False
      ws.Delete
      Application.DisplayAlerts = True
    End If
  Next
End If
End Sub
Private Sub AnzeigeAn()
   With Application
      .EnableEvents = True
      .ScreenUpdating = True
   End With
End Sub
Sub Gesamt()
   Application.EnableEvents = True
End Sub
Private Sub ArztAnlegen(rngB As Range)
   Dim rngK As Range, lngI As Long
   For Each rngK In rngB
      If rngK.Row > 1 Then
         If Len(rngK) < 32 And rngK <> "" Then
            For lngI = 1 To Sheets.Count
               If Sheets(lngI).Name = "" & rngK Then
                  MsgBox "Das Blatt " & rngK & " gibt es schon!"
                  Exit For
               End If
            Next lngI
            If lngI > Sheets.Count Then
               Sheets("Muster").Copy After:=Sheets(lngI - 1)
               With ActiveSheet
                  .Name = rngK
                  .Cells(7, 4) = rngK
                  .Visible = True
               End With
            End If
         End If
      End If
   Next rngK
End Sub

Anzeige
Kleine Änderung, Code an falscher Stelle!
23.08.2008 21:34:00
Backowe
Hi,
VBA-Code:
Option Explicit
Public AlterWert As String
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("K2:K" & Cells(Rows.Count, "K").End(xlUp).Row)) Is Nothing And Target.Count = 1 Then _
  AlterWert = Target.Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
   Dim Tab2 As Range, rowOffset As Long, strAdress As String
   Dim B As Long, A As Long, C As Long
   Dim ws As Worksheet
    If Not Intersect(Target, Range("K2:K" & Cells(Rows.Count, "K").End(xlUp).Row)) Is Nothing And _
      Target.Count = 1 And Target = "" Then
      For Each ws In Worksheets
        If ws.Name = AlterWert Then
          Application.DisplayAlerts = False
          ws.Delete
          Application.DisplayAlerts = True
        End If
      Next
    End If
   If Not Intersect(Target, Range("B3")) Is Nothing Then
      With Application
         .EnableEvents = False
         .ScreenUpdating = False
      End With
      On Error GoTo Fehler1:
      With Tabelle2
         rowOffset = .Rows(2).Find(What:=Range("B3"), LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False).Column - 3
         Range("B5:B" & Rows.Count).ClearContents
         strAdress = .Range(.Cells(4, rowOffset), _
            .Cells(56, rowOffset)).Address
         .Range(strAdress).Copy Range("B5")
         Range("E5:G" & Rows.Count).ClearContents
         strAdress = .Range(.Cells(4, rowOffset + 1), _
            .Cells(56, rowOffset + 5)).Address
            .Range(strAdress).Copy Range("C5")
      End With
   ElseIf Not Intersect(Target, Columns(11)) Is Nothing Then
      ArztAnlegen Intersect(Target, Columns(11))
      Me.Activate
   End If
Fehler1:
   AnzeigeAn
   If Err.Number <> 0 Then
      MsgBox Err.Description, vbCritical, "Fehler beim Lesen!"
      Exit Sub
   End If
   On Error GoTo Fehler:
    If Selection.Count > 1 Then
      For C = 1 To Selection.Count
         If Intersect(Selection(C), Range("E5:G56", "B5:B56")) Is Nothing Then _
            Exit Sub
         AnzeigeAn
         B = Tabelle2.Rows(2).Find(What:=Range("B3"), LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False).Column - 2
         For A = 0 To 5
            If A <> 3 Then
               If A = 5 Then
                  Tabelle2.Cells(Selection(C).Row - 1, B - 1) = _
                     Cells(Selection(C).Row, 2).Value
               Else
                  Tabelle2.Cells(Selection(C).Row - 1, B + A).Value = _
                     Cells(Selection(C).Row, 3 + A).Value
               End If
            End If
         Next A
      Next C
   Else
      If Intersect(Target, Range("E5:G56", "B5:B56")) Is Nothing Then Exit Sub
      AnzeigeAn
      B = Tabelle2.Rows(2).Find(What:=Range("B3"), LookIn:=xlFormulas, _
         LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
         MatchCase:=False, SearchFormat:=False).Column - 2
      For A = 0 To 5
         If A <> 3 Then
            If A = 5 Then
               Tabelle2.Cells(Target.Row - 1, B - 1) = Cells(Target.Row, 2).Value
            Else
               Debug.Print Cells(Target.Row, 3 + A)
               Tabelle2.Cells(Target.Row - 1, B + A).Value = _
                  Cells(Target.Row, 3 + A).Value
            End If
         End If
      Next A
   End If
Fehler:
   AnzeigeAn
   If Err.Number <> 0 Then MsgBox Err.Description, vbCritical, _
      "Fehler beim schreiben!"
End Sub
Private Sub AnzeigeAn()
   With Application
      .EnableEvents = True
      .ScreenUpdating = True
   End With
End Sub
Sub Gesamt()
   Application.EnableEvents = True
End Sub
Private Sub ArztAnlegen(rngB As Range)
   Dim rngK As Range, lngI As Long
   For Each rngK In rngB
      If rngK.Row > 1 Then
         If Len(rngK) < 32 And rngK <> "" Then
            For lngI = 1 To Sheets.Count
               If Sheets(lngI).Name = "" & rngK Then
                  MsgBox "Das Blatt " & rngK & " gibt es schon!"
                  Exit For
               End If
            Next lngI
            If lngI > Sheets.Count Then
               Sheets("Muster").Copy After:=Sheets(lngI - 1)
               With ActiveSheet
                  .Name = rngK
                  .Cells(7, 4) = rngK
                  .Visible = True
               End With
            End If
         End If
      End If
   Next rngK
End Sub
Gruß Jürgen

Anzeige
AW: Kleine Änderung, Code an falscher Stelle!
23.08.2008 22:13:00
oblivion
Hallo, dein Code funktioniert, aber ich bin auf noch ein löeines Problem gestoßen. Ich habe meine Arbeitsmappe geschützt. Bei dem Makro wo ich die Tabellenblätter erstellen lasse, habe ich den Befehl ActiveWorkbook.Unprotect "daten" und ActiveWorkbook.protect "daten" gesetzt. Das funktioniert auch wunderbar. Aber ich muss diesen Befehl ja auch setzten wenn das Makro von dir die Tabellen wieder löschen will. Nur weiß ich nicht wo ich das hin setzten soll. Hab schon ein paar Positionen ausprobiert aber nichts hat geklappt. Danke für deine Hilfe.
Gruß Oblivion

Hier einfügen!
23.08.2008 22:36:00
Backowe
Hi,
VBA-Code:
Option Explicit
Public AlterWert As String
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("K2:K" & Cells(Rows.Count, "K").End(xlUp).Row + 1)) Is Nothing And Target.Count = 1 Then _
  AlterWert = Target.Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
   Dim Tab2 As Range, rowOffset As Long, strAdress As String
   Dim B As Long, A As Long, C As Long
   Dim ws As Worksheet
    If Not Intersect(Target, Range("K2:K" & Cells(Rows.Count, "K").End(xlUp).Row + 1)) Is Nothing And _
      Target.Count = 1 And Target = "" Then
      ActiveWorkbook.Unprotect "daten"
      For Each ws In Worksheets
        If ws.Name = AlterWert Then
          Application.DisplayAlerts = False
          ws.Delete
          Application.DisplayAlerts = True
        End If
      Next
    ActiveWorkbook.Protect "daten"
    End If
   If Not Intersect(Target, Range("B3")) Is Nothing Then
      With Application
         .EnableEvents = False
         .ScreenUpdating = False
      End With
      On Error GoTo Fehler1:
      With Tabelle2
         rowOffset = .Rows(2).Find(What:=Range("B3"), LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False).Column - 3
         Range("B5:B" & Rows.Count).ClearContents
         strAdress = .Range(.Cells(4, rowOffset), _
            .Cells(56, rowOffset)).Address
         .Range(strAdress).Copy Range("B5")
         Range("E5:G" & Rows.Count).ClearContents
         strAdress = .Range(.Cells(4, rowOffset + 1), _
            .Cells(56, rowOffset + 5)).Address
            .Range(strAdress).Copy Range("C5")
      End With
   ElseIf Not Intersect(Target, Columns(11)) Is Nothing Then
      ArztAnlegen Intersect(Target, Columns(11))
      Me.Activate
   End If
Fehler1:
   AnzeigeAn
   If Err.Number <> 0 Then
      MsgBox Err.Description, vbCritical, "Fehler beim Lesen!"
      Exit Sub
   End If
   On Error GoTo Fehler:
    If Selection.Count > 1 Then
      For C = 1 To Selection.Count
         If Intersect(Selection(C), Range("E5:G56", "B5:B56")) Is Nothing Then _
            Exit Sub
         AnzeigeAn
         B = Tabelle2.Rows(2).Find(What:=Range("B3"), LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False).Column - 2
         For A = 0 To 5
            If A <> 3 Then
               If A = 5 Then
                  Tabelle2.Cells(Selection(C).Row - 1, B - 1) = _
                     Cells(Selection(C).Row, 2).Value
               Else
                  Tabelle2.Cells(Selection(C).Row - 1, B + A).Value = _
                     Cells(Selection(C).Row, 3 + A).Value
               End If
            End If
         Next A
      Next C
   Else
      If Intersect(Target, Range("E5:G56", "B5:B56")) Is Nothing Then Exit Sub
      AnzeigeAn
      B = Tabelle2.Rows(2).Find(What:=Range("B3"), LookIn:=xlFormulas, _
         LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
         MatchCase:=False, SearchFormat:=False).Column - 2
      For A = 0 To 5
         If A <> 3 Then
            If A = 5 Then
               Tabelle2.Cells(Target.Row - 1, B - 1) = Cells(Target.Row, 2).Value
            Else
               Debug.Print Cells(Target.Row, 3 + A)
               Tabelle2.Cells(Target.Row - 1, B + A).Value = _
                  Cells(Target.Row, 3 + A).Value
            End If
         End If
      Next A
   End If
Fehler:
   AnzeigeAn
   If Err.Number <> 0 Then MsgBox Err.Description, vbCritical, _
      "Fehler beim schreiben!"
End Sub
Private Sub AnzeigeAn()
   With Application
      .EnableEvents = True
      .ScreenUpdating = True
   End With
End Sub
Sub Gesamt()
   Application.EnableEvents = True
End Sub
Private Sub ArztAnlegen(rngB As Range)
   Dim rngK As Range, lngI As Long
   For Each rngK In rngB
      If rngK.Row > 1 Then
         If Len(rngK) < 32 And rngK <> "" Then
            For lngI = 1 To Sheets.Count
               If Sheets(lngI).Name = "" & rngK Then
                  MsgBox "Das Blatt " & rngK & " gibt es schon!"
                  Exit For
               End If
            Next lngI
            If lngI > Sheets.Count Then
               Sheets("Muster").Copy After:=Sheets(lngI - 1)
               With ActiveSheet
                  .Name = rngK
                  .Cells(7, 4) = rngK
                  .Visible = True
               End With
            End If
         End If
      End If
   Next rngK
End Sub
Gruß Jürgen

Anzeige
Kleine Änderung!
23.08.2008 21:57:00
Backowe
Hi,
ändere in Worksheet_SelectionChange und Worksheet_Change bitte noch folgendes:
If Not Intersect(Target, Range("K2:K" & Cells(Rows.Count, "K").End(xlUp).Row + 1)) Is Nothing ...
Gruß Jürgen

AW: Kleine Änderung!
23.08.2008 23:49:00
oblivion
Hallo, danke für den Hinweis. Jetzt klappt alles wunderbar. Das einzigste Problem dürfte jetzt noch sein, dass die PCs auf Arbeit zu langsam sind. Mal schauen. Gruß Oblivion

304 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige