Die Methode 'Open' für das Objekt 'Workbooks' ist
07.03.2016 21:18:03
Christian
Seltsam ist allerdings, dass das Makro durchläuft und bei dutzenden von Files funktioniert und _ dann plötzlich die Fehlermeldung erscheint:
Laufzeitfehler '1004'
Die Methode 'Open' für das Objekt 'Workbooks' ist fehlgeschlagen
Ich vermutete ein Problem mit der Datei. Wenn man jedoch die Datei völlig entfernt, tritt der Fehler einfach bei einer anderen Datei auf.
Selbst wenn man die Datei, welche den Fehler verursacht, entfernt und mit einer gleichnamigen Datei ersetzt bei der das Makro zuvor durchgelaufen ist, geht es plötzlich nicht mehr.
An der Menge der Dateien kann es nicht liegen, denn die hat sich nicht geändert, als es plötzlich aufgehört hat zu funktionieren.
Hier noch der komplette Code, der wie gesagt, bisher funktioniert hat und ohne erkennbare Ursache plötzlich nicht mehr geht.
Gibt es einen Tipp oder Anhaltspunkt woran das liegen könnte?
Option Explicit
Option Compare Text
Sub zusammensetzen()
Dim i
Dim myfolder
Dim mytabelle
Dim myrange
Dim mylines
Dim betragzelle
Dim myfilename
Dim berechnungsdatum
Dim fso As Object
Dim fol As Object
Dim fil As Object
'Where you define what to "zusammensetzen"
myfolder = Range("D4") 'Pfad zu den Arbeitsrapporten
mytabelle = Range("D6") 'Name der zu bearbeitenden Tabelle
myrange = Range("D9") 'Bereich in der Tabelle, welcher kopiert werden soll ( _
Feldwert(e)):
mylines = Range(myrange).Rows.Count 'zum Berechnen der Zeile zum nächsten Einfügen
betragzelle = Range("D11") 'Position, bei welcher mit Einfügen begonnen werden soll
berechnungsdatum = Date 'Das aktuelle Datum, wird in der Totalzeile ausgegeben
i = 0
Set fso = CreateObject("Scripting.FileSystemObject")
Set fol = fso.GetFolder(myfolder)
'Zuerst wird das gesamte Tabellenblatt von Inhalt und Formatierungen befreit
'ThisWorkbook.Worksheets("Auswertung").Activate
'ActiveSheet.UsedRange.Clear
ThisWorkbook.Worksheets("Auswertung").Cells.Clear 'scheint mir etwas schneller zu sein
For Each fil In fol.Files
i = i + 1
Workbooks.Open Filename:=fil
myfilename = Right(fil, Len(fil) - Len(myfolder))
Sheets(mytabelle).Activate
Range(myrange).Copy
With ThisWorkbook.Worksheets("Auswertung").Range(betragzelle).offset(rowOffset:=(i * _
mylines - mylines), columnOffset:=1)
.PasteSpecial Paste:=xlPasteValues
ThisWorkbook.Worksheets("Auswertung").Range(betragzelle).offset(i * mylines - mylines). _
Value = myfilename
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = RGB(255, 213, 0)
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End With
ActiveWorkbook.Close False
Next fil
i = i + 2
With ThisWorkbook.Worksheets("Auswertung").Range(betragzelle).offset(rowOffset:=(i * _
mylines - mylines), columnOffset:=1)
.FormulaR1C1 = "=SUM(R[-" & i & "]C:R[-1]C)"
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlDouble
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThick
End With
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With .Font
.Size = 12
End With
End With
ThisWorkbook.Worksheets("Auswertung").Range(betragzelle).offset(i * mylines - mylines). _
Value = "Total: (" & berechnungsdatum & ")"
End Sub