Excel 2007 VBA Tabellenblatt löschen

Rossi33 · 27. März 2012 um 18:58

Hallo Zusammen,

ich suche einen VBA Code für das Löschen eines Tabellenblattes.

Erklärung:

Im Tabellenblatt „Basis“ werden in Spalte A9:A20 Nummer eingetragen und dann automatisch Tabellenblätter mit diesen Nummer als Tabellennamen erstellt. Dies geschieht mit diesem Code:

Sub Worksheet_Change(ByVal Target As Range)
Set Target = Intersect(Target, Range(„A9:A22“))
If Target Is Nothing Then Exit Sub
Call Erstelle(Target)
End Sub

Sub Erstelle(ByRef Target As Range)
Dim Zelle As Range
On Error GoTo hell
For Each Zelle In Target
If Zelle.Value „“ Then
If Not Vorhanden(Zelle.Value) = True Then
Worksheets(„Basis“).Copy after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Zelle.Value
End If
End If
Next Zelle
Worksheets(„Anlagen Total“).Activate
hell:
If Err.Number 0 Then
MsgBox Err.Number & vbCrLf & Err.Description
Resume Next
End If
End Sub

Function Vorhanden(strWert As String) As Boolean
Dim wks As Worksheet
For Each wks In Worksheets
If wks.Name = strWert Then
Vorhanden = True
Exit For
End If
Next wks
End Function

Nun möchte ich in diesen Code die Löschung integrieren, die wie folgt ausgeführt werden soll.
Wenn ich die Nummer im Tabellenblatt „Basis“ nun wieder lösche, soll auch das zugehörige Tabellenblatt gelöscht werden.

Ist das irgendwie möglich ?

Vielen Dank

Reinhard_fb8cb7 · 27. März 2012 um 20:13

Hallo Rossi,

Im Tabellenblatt „Basis“ werden in Spalte A9:A20 Nummer
eingetragen und dann automatisch Tabellenblätter mit diesen
Nummer als Tabellennamen erstellt.

A9:A20? Im Code steht A9:A22.

Wenn ich die Nummer im Tabellenblatt „Basis“ nun wieder
lösche, soll auch das zugehörige Tabellenblatt gelöscht
werden.

Option Explicit

Sub Worksheet\_Change(ByVal Target As Range)
Set Target = Intersect(Target, Range("A9:A22"))
If Target Is Nothing Then Exit Sub
Call Erstelle(Target)
Call Loesche(Target)
End Sub

Sub Erstelle(ByRef Target As Range)
Dim Zelle As Range
On Error GoTo hell
For Each Zelle In Target
 If Zelle.Value "" Then
 If Not Vorhanden(Zelle.Value) = True Then
 Worksheets("Basis").Copy after:=Worksheets(Worksheets.Count)
 ActiveSheet.Name = Zelle.Value
 End If
 End If
Next Zelle
Worksheets("Anlagen Total").Activate
hell:
If Err.Number 0 Then
 MsgBox Err.Number & vbCrLf & Err.Description
 Resume Next
End If
End Sub

Sub Loesche(ByRef Target As Range)
Dim wks As Worksheet, Zelle As Range, Vorh As Boolean
Application.DisplayAlerts = False
For Each wks In Worksheets
 If IsNumeric(wks.Name) Then
 Vorh = False
 For Each Zelle In Target
 If Zelle.Value = wks.Name Then
 Vorh = True
 Exit For
 End If
 Next Zelle
 If Not Vorh Then wks.Delete
 End If
Next wks
Application.DisplayAlerts = True
End Sub

Function Vorhanden(strWert As String) As Boolean
Dim wks As Worksheet
For Each wks In Worksheets
 If wks.Name = strWert Then
 Vorhanden = True
 Exit For
 End If
Next wks
End Function

Gruß
Reinhard

Rossi33 · 27. März 2012 um 20:30

Hallo Reinhard,

habe mich mit dem Bereich vertan, Ist natürlich A9:A22. Die Tabellen werden nun gelöscht, jedoch tritt das Problem auf, das er mir beim anlegen der Tabellen (Eintragung Nummer in Basistabelle) nur noch ein Tabellenblatt anlegt und die anderen überschreibt. Somit wird immer nur ein Tabellenblatt angelegt.

Danke für Deine Hilfe.

Gruss Marco

Reinhard_fb8cb7 · 27. März 2012 um 22:59

habe mich mit dem Bereich vertan, Ist natürlich A9:A22. Die
Tabellen werden nun gelöscht, jedoch tritt das Problem auf,
das er mir beim anlegen der Tabellen (Eintragung Nummer in
Basistabelle) nur noch ein Tabellenblatt anlegt und die
anderen überschreibt. Somit wird immer nur ein Tabellenblatt
angelegt.

Hallo Marco,

ja, mein Fehler. Teste bitte mal den nachfolgenden Code.

Gruß
Reinhard

Option Explicit

Sub Worksheet\_Change(ByVal Target As Range)
Set Target = Intersect(Target, Range("A9:A22"))
If Target Is Nothing Then Exit Sub
Call Erstelle(Target)
Call Loesche(Target)
Worksheets("Anlagen Total").Activate
End Sub

Sub Erstelle(ByRef Target As Range)
Dim Zelle As Range
On Error GoTo hell
For Each Zelle In Target
 If Zelle.Value "" Then
 If Not Vorhanden(Zelle.Value) = True Then
 Worksheets("Basis").Copy after:=Worksheets(Worksheets.Count)
 ActiveSheet.Name = Zelle.Value
 End If
 End If
Next Zelle
hell:
If Err.Number 0 Then
 MsgBox Err.Number & vbCrLf & Err.Description
 Resume Next
End If
End Sub

Sub Loesche(ByRef Target As Range)
Dim wks As Worksheet, Zelle As Range, Vorh As Boolean
Application.DisplayAlerts = False
With Worksheets("Basis")
 For Each wks In Worksheets
 If IsNumeric(wks.Name) Then
 If Application.WorksheetFunction.CountIf(.Range("A9:A22"), Val(wks.Name)) = 0 Then
 wks.Delete
 End If
 End If
 Next wks
End With
Application.DisplayAlerts = True
End Sub

Function Vorhanden(strWert As String) As Boolean
Dim wks As Worksheet
For Each wks In Worksheets
 If wks.Name = strWert Then
 Vorhanden = True
 Exit For
 End If
Next wks
End Function

Rossi33 · 28. März 2012 um 06:34

Guten Morgen Reinhard,

bei diesem Code legt er leider keine Tabellenblätter an. Kann man hier auch eine Excel Tabelle hoch laden ? Dann würde ich Sie Dir mal schicken.

Vielen Dank für Deine Super Hilfe.

Gruss Marco

Reinhard_fb8cb7 · 28. März 2012 um 15:50

bei diesem Code legt er leider keine Tabellenblätter an. Kann
man hier auch eine Excel Tabelle hoch laden ? Dann würde ich
Sie Dir mal schicken.

Hallo Marco,

lade sie hoch mit fileupload o.ä., s. FAQ:2606

Gruß
Reinhard

Rossi33 · 28. März 2012 um 20:00

Hallo Reinhard,

bin bei keiner dieser Seite angemeldet. Hier meine Pseudomail Adresse. Schick mir doch eine Mail, dann sende ich Dir die Datei, oder hast Du vielleicht inzwischen eine Lösung gefunden ? [MOD]Mail-Adresse entfernt

Gruss Rossi

Reinhard_fb8cb7 · 28. März 2012 um 20:06

bin bei keiner dieser Seite angemeldet. Hier meine Pseudomail
Adresse. Schick mir doch eine Mail, dann sende ich Dir die
Datei, oder hast Du vielleicht inzwischen eine Lösung gefunden
? [email protected]

Hallo Rossi,

in der FAQ:2606 siehst du den Link zu z.B. fileupload.
Dem folgst du, auf deren Seite wählst du erst „Durchsuchen“,
dann „Hochladen“…
Die Seite zeigt dir dann einen Runterladlink, den zeigst du hier bei w-w-w.

Gruß
Reinhard

Rossi33 · 28. März 2012 um 20:14

http://www.file-upload.net/download-4220705/Tabellen…

So einfach ist das ? Lach

Reinhard_fb8cb7 · 28. März 2012 um 20:28

http://www.file-upload.net/download-4220705/Tabellen…

Hallo Rossi,

in das Modul des Blattes „Anlagen Total“

Option Explicit

Sub Worksheet_Change(ByVal Target As Range)
Set Target = Intersect(Target, Range(„A9:A22“))
If Target Is Nothing Then Exit Sub
Call Erstelle(Target)
Call Loesche(Target)
Worksheets(„Anlagen Total“).Activate
End Sub"

In ein Standardmodul, Modul1, Modul2 o.ä.

Option Explicit

Sub Erstelle(ByRef Target As Range)
Dim Zelle As Range
On Error GoTo hell
For Each Zelle In Target
 If Zelle.Value "" Then
 If Not Vorhanden(Zelle.Value) = True Then
 Worksheets("Basis").Copy after:=Worksheets(Worksheets.Count)
 ActiveSheet.Name = Zelle.Value
 End If
 End If
Next Zelle
hell:
If Err.Number 0 Then
 MsgBox Err.Number & vbCrLf & Err.Description
 Resume Next
End If
End Sub

Sub Loesche(ByRef Target As Range)
Dim wks As Worksheet, Zelle As Range, Vorh As Boolean
Application.DisplayAlerts = False
With Worksheets("Anlagen Total")
 For Each wks In Worksheets
 If IsNumeric(wks.Name) Then
 If Application.WorksheetFunction.CountIf(.Range("A9:A22"), Val(wks.Name)) = 0 Then
 wks.Delete
 End If
 End If
 Next wks
End With
Application.DisplayAlerts = True
End Sub

Function Vorhanden(strWert As String) As Boolean
Dim wks As Worksheet
For Each wks In Worksheets
 If wks.Name = strWert Then
 Vorhanden = True
 Exit For
 End If
Next wks
End Function

Gruß
Reinhard

Rossi33 · 28. März 2012 um 21:10

Hallo Reinhard,

hat alles super geklappt. Ich danke Dir vielmals für Deine Hilfe.

Jetzt kann ich an der Tabelle weiterbauen bis ich auf die nächsten Probleme stosse.

Nochmals besten Dank.

Gruss Rossi