Hallo Zusammen,

ich erhalte bei folgendem Code ab und zu einen Laufzeitcode 1004. In den Excel Dokumenten sollen nur 7 Sheets erhalten bleiben,

alle anderen müssen in eine Datei alt_Dateiname.xls verschoben und Archiviert  werden. Ich habe auch schon andere Variationen z.B 1 oder ein Sheetnamen eingaetragen. Vielen Dank für eure Hilfe!

In der Fetten Zeile kommt ein Laufzeitcode 1004:

Private Sub Workbook_Open()
           Dim sheetnmr As Integer ' variable für sheets die weg kommen
            Dim anzSheets As Integer
            anzSheets = 7           'maximal x vorhandene
            sheetnmr = ActiveWorkbook.Sheets.Count 'Anzahl Arbeitsblätter
           If sheetnmr > anzSheets Then     'maximal x vorhandene
           
                Dim test As New Excel.Application  'Excel Applikationen
                
                Dim pfad As String       'pfad zur Liferantenliste
                Dim name As String       'Name des Fensters
                        
                pfad = ActiveWorkbook.Path
                name = ActiveWorkbook.name
                alt_name = "alt_" & name     'name History
                alt_pfad = pfad & "\History\"    'Pfad History
                      
                
                'Windows(name).Activate
                Workbooks.Open alt_pfad & alt_name 'History Datei öffnen
                                    
                While sheetnmr > anzSheets
                  Windows(name).Activate
                  On Error GoTo 0
                  ActiveWorkbook.Sheets(sheetnmr).Move After:=Workbooks(alt_name).Sheets(Workbooks(alt_name).Sheets.Count)  'überflüssige Sheets in History Datei verschieben
                  sheetnmr = sheetnmr - 1    'zaehler runterzaehlen
                Wend
                
                EnableEvents = False        'evtl. Meldungen deaktivieren
                Application.DisplayAlerts = True
                
                ActiveWorkbook.Save     'history speichern und schließen
                ActiveWorkbook.Close
                test.Quit
                
                Windows(name).Activate
                ActiveWorkbook.Save     'Liste speichern
           End If
End Sub