Tabellenblätter löschen

Liebe VBA-Cracks, ich komme mit einem Skript nicht weiter. Ich möchte in einer Datei alle Tabellenblätter löschen bis auf ein bestimmtes Blatt. Die Blätter werden jedoch nicht gelöscht und das Skript läuft nicht bis zum Schluss durch. Zur Fehlersuche habe ich einen alternativen Code verwendet und anstelle des Lösch-Befehls das Einfärben der Register getestet. Dies funktioniert einwandfrei und das Skript läuft bis zum Schluss durch. Was ist falsch? Danke für die Hilfe.

Option Explicit
Sub Extern_Publikation_FI()

'Variablendeklaration
Dim strPfad As String
Dim strPublikationsdatei As String
Dim mySheet As String
Dim ws As Worksheet

'Variablenwerte
strPfad = ThisWorkbook.Path & "\"
strPublikationsdatei = "FI_2023"
mySheet = "FTE_Extern Test_FI"

'---------
'Start
'---------
'Datei kopieren
ThisWorkbook.Sheets.Copy

'Neue Datei abspeichern als .xlsx-Datei
With ActiveWorkbook
.SaveAs Filename:=strPfad & strPublikationsdatei, FileFormat:=xlOpenXMLWorkbook
End With

'Tabellenblätter entfernen
Application.DisplayAlerts = False
For Each ws In ActiveWorkbook.Worksheets
If ws.Name > mySheet Then

'Löschen funktioniert nicht
ws.Delete

'Einfärben der Register funktioniert
'ws.Tab.ColorIndex = 3
End If
Next ws
Application.DisplayAlerts = True

'Neue Datei schliessen
With ActiveWorkbook
.Save
.Close
End With

'---------
'Ende
'---------

MsgBox "Publikationsdatei FI_2023 ist erstellt!" & vbNewLine & vbNewLine & "Dateiablage: " & vbNewLine & strPfad

Exit Sub
FehlerMarke:
MsgBox "Es ist ein Fehler aufgetreten. Das Makro wurde nicht ausgeführt."
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub Extern_Publikation_FI() 'Variablendeklaration Dim strPfad As String Dim strPublikationsdatei As String Dim mySheet As String Dim ws As Worksheet 'Variablenwerte strPfad = ThisWorkbook.Path & "\" strPublikationsdatei = "FI_2023" mySheet = "FTE_Extern Test_FI" '--------- 'Start '--------- 'Datei kopieren ThisWorkbook.Sheets.Copy 'Neue Datei abspeichern als .xlsx-Datei With ActiveWorkbook .SaveAs Filename:=strPfad & strPublikationsdatei, FileFormat:=xlOpenXMLWorkbook End With 'Tabellenblätter entfernen Application.DisplayAlerts = False For Each ws In ActiveWorkbook.Worksheets If ws.Name > mySheet Then 'Löschen funktioniert nicht ws.Delete 'Einfärben der Register funktioniert 'ws.Tab.ColorIndex = 3 End If Next ws Application.DisplayAlerts = True 'Neue Datei schliessen With ActiveWorkbook .Save .Close End With '--------- 'Ende '--------- MsgBox "Publikationsdatei FI_2023 ist erstellt!" & vbNewLine & vbNewLine & "Dateiablage: " & vbNewLine & strPfad Exit Sub FehlerMarke: MsgBox "Es ist ein Fehler aufgetreten. Das Makro wurde nicht ausgeführt." End Sub

Sub Extern_Publikation_FI() 'Variablendeklaration Dim strPfad As String Dim strPublikationsdatei As String Dim mySheet As String Dim ws As Worksheet 'Variablenwerte strPfad = ThisWorkbook.Path & "\" strPublikationsdatei = "FI_2023" mySheet = "FTE_Externes Personal_DPM_FI" '--------- 'Start '--------- On Error GoTo FehlerMarke 'Datei kopieren ThisWorkbook.Sheets.Copy 'Tabellenblätter entfernen Application.DisplayAlerts = False For Each ws In ActiveWorkbook.Worksheets If ws.Name > mySheet Then 'Löschen funktioniert nicht ws.Delete 'Einfärben der Register funktioniert 'ws.Tab.ColorIndex = 3 End If Next ws Application.DisplayAlerts = True With ActiveWorkbook .SaveAs Filename:=strPfad & strPublikationsdatei, FileFormat:=xlOpenXMLWorkbook .Close End With '--------- 'Ende '--------- Exit Sub FehlerMarke: MsgBox "Fehler Nummer" & Err.Number & vbCrLf & Err.Description End Sub

Dim a As Integer 'Tabellenblätter entfernen Application.DisplayAlerts = False For a = ActiveWorkbook.Sheets.Count To 1 Step -1 With ActiveWorkbook.Sheets(a) If .Name > mySheet Then 'Löschen funktioniert ? .Delete 'Einfärben der Register funktioniert 'ws.Tab.ColorIndex = 3 End If End With Next

'Datei kopieren ThisWorkbook.Sheets.Copy Dim wbkNew As Workbook Set wbkNew = ActiveWorkbook Application.DisplayAlerts = False For Each ws In wbkNew.Worksheets If Not (ws.Name = mySheet) Then Debug.Print ws.Name ws.Delete End If Next ws Application.DisplayAlerts = True 'Neue Datei speichern und schliessen With wbkNew .SaveAs Filename:=strPfad & strPublikationsdatei, FileFormat:=xlOpenXMLWorkbook .Close End With

On Error Resume Next Application.DisplayAlerts = False ws.Delete Application.DisplayAlerts = True On Error GoTo FehlerMarke

xxx = "Tabelle1, Tabelle2, Tabelle4" thisworkbook.activate check = true for each ws in thisworkbook.Worksheets if instr(xxx, ws.Name) > 0 then ws.Select check check = false end if next if not check then ActiveWindow.SelectesSheets.Copy

dim WB as Workbook dim ws as worksheet thisworkbook.Sheets.copy set wb = ActiveWorkbook for each ws in wb.worksheets if ws.Name > "xxx wie auch immer" AND wb.Worksheets.count > 1 then ws.Delete next

Sub Extern_Publikation_FI() 'Variablendeklaration Dim strPfad As String Dim strPublikationsdatei As String Dim mySheet As String Dim ws As Worksheet Dim sheetsToCopy() As Variant 'Variablenwerte strPfad = ThisWorkbook.Path & "\" strPublikationsdatei = "FI_2023" mySheet = "FTE_Externes Personal_DPM_FI" sheetsToCopy = Array("Tabelle1", "Tabelle2") '--------- 'Start '--------- On Error GoTo FehlerMarke 'Datei kopieren ThisWorkbook.Activate ThisWorkbook.Sheets(sheetsToCopy).Copy With ActiveWorkbook .SaveAs Filename:=strPfad & strPublikationsdatei, FileFormat:=xlOpenXMLWorkbook .Close End With '--------- 'Ende '--------- Exit Sub FehlerMarke: MsgBox "Fehler Nummer" & Err.Number & vbCrLf & Err.Description End Sub

Option Explicit Sub Extern_Publikation_FI() Dim strPfad As String Dim strPublikationsdatei As String Dim mySheet As String Dim ws As Worksheet 'Variablenwerte strPfad = ThisWorkbook.Path & "\" strPublikationsdatei = "FI_2023" mySheet = "FTE_Extern Test_FI" ThisWorkbook.Sheets(mySheet).Copy ActiveWorkbook.SaveAs Filename:=strPfad _ & strPublikationsdatei, FileFormat:=xlOpenXMLWorkbook With ActiveWorkbook .Save .Close End With MsgBox "Publikationsdatei FI_2023 ist erstellt!" _ & vbNewLine & vbNewLine & "Dateiablage: " _ & vbNewLine & strPfad Exit Sub FehlerMarke: MsgBox "Es ist ein Fehler aufgetreten. Das Makro wurde nicht ausgeführt." End Sub

With ActiveWorkbook .Sheets("Bestimmtes Blatt").Move before:=.Sheets(1) Application.DisplayAlerts = False Do Until .Sheets.Count = 1 .Sheets(2).Delete Loop Application.DisplayAlerts = True End With

Beliebteste Forumthreads (12 Monate)

28 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

28
Beiträge zum Forumthread

Beiträge zu diesem Forumthread