1k Aufrufe
Gefragt in Tabellenkalkulation von
Hallo zusammen, ich habe diesen Code in VBA geschrieben. Der soll mir immer die neueste Datei aus einem Verzeichnis in eine neues Tabellenblatt kopieren. Der Code scheint auch zu funktionieren, aber Excel stürzt beim ausführen ab. jetzt ist meine Frage, ob der folgenden Code fehlerhaft ist?

Option Explicit
Public Sub Test()
Dim strFileNew As String
Dim strFileName As String
Dim strPath As String
Dim intTMP As Integer
Dim datTime As Date
On Error GoTo Fin
Application.ScreenUpdating = False
strPath = "A:\Projekte (laufende)\SmartHome\1_AP Liste\" ' anpassen!!!
intTMP = 1
strFileName = Dir$(strPath & "*.xls*")
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
strFileNew = strTmpFileName
datTime = FileDateTime(strPath & strFileName)
Do While strFileName <> ""
If datTime < FileDateTime(strPath & strFileName) Then
datTime = FileDateTime(strPath & strFileName)
strFileNew = strFileName
If Not strFileName = ThisWorkbook.Name Then
Workbooks.Open (strPath & strFileName)

With ActiveWorkbook
.Worksheets(1).Copy _
After:=ThisWorkbook.Worksheets _
(ThisWorkbook.Worksheets.Count)
.Close False
With ThisWorkbook
.Worksheets(.Worksheets.Count).Name = "Auftragsliste" & intTMP
End With
intTMP = intTMP + 1
End With
strFileName = Dir$()
Else
strFileName = Dir$()
End If
Loop
Fin:
Application.ScreenUpdating = True
End Sub


VG
S.K

2 Antworten

0 Punkte
Beantwortet von
Hi,

wahrscheinlich bist du mit den End If's durcheinander gekommen.
Wenn die nicht an der richtigen Stelle stehen, kann es u.U. sein, dass deine Schleife nicht verlassen werden kann, weil der Befehl zum auslesen der nächsten Datei aufgrund nicht eingetroffener Bedingung einfach nicht ausgeführt wird. Dann hängt sich Excel gern auf, weil alle Ressourcen dazu benötigt werden, zu versuchen die Dauerschleife zu verlassen und den Code zu beenden. Manchmal kann man seine Daten mit Druck auf die Esc-Taste noch retten. Oft bleibt einem aber nur das harte Beenden über den Task-Manager. Alle Änderungen sind dann futsch.

Hier eine Variante, wie dein Code möglicherweise aussehen müsste.
Option Explicit
Public Sub Test()

Dim strFileNew As String
Dim strFileName As String
Dim strPath As String
Dim intTMP As Integer
Dim datTime As Date

On Error GoTo Fin

Application.ScreenUpdating = False

strPath = "A:\Projekte (laufende)\SmartHome\1_AP Liste\"
intTMP = 1

If Right(strPath, 1) <> "\" Then strPath = strPath & "\" '<-- Diese beiden Zeilen
strFileName = Dir$(strPath & "*.xls*") 'mussten getauscht werden.


strFileNew = strFileName
datTime = FileDateTime(strPath & strFileName)
Do While strFileName <> ""

If datTime < FileDateTime(strPath & strFileName) Then
datTime = FileDateTime(strPath & strFileName)
strFileNew = strFileName
If Not strFileName = ThisWorkbook.Name Then
Workbooks.Open (strPath & strFileName)

With ActiveWorkbook
.Worksheets(1).Copy _
After:=ThisWorkbook.Worksheets _
(ThisWorkbook.Worksheets.Count)
.Close False
With ThisWorkbook
.Worksheets(.Worksheets.Count).Name = "Auftragsliste" & intTMP
End With
intTMP = intTMP + 1
End With
strFileName = Dir$()
End If '<-- diese Zeile hat gefehlt.
Else
strFileName = Dir$()
End If
Loop
Fin:
Application.ScreenUpdating = True
End Sub
Leider hab ich nicht verstanden, was du mit der Variable strTmpFileName vorhast. Diese ist weder definiert noch wird ihr ein Wert zugewiesen.

Ein weiteres Problem: Sobald du den Code erneut ausführst, und dabei wieder bei 1 anfängst, wird derzeit versucht, dem kopierten Blatt der ersten Datei ein Name zuzuweisen, welcher bereits existiert. Es kommt zum Fehler und der Code wird vorzeitig abgebrochen ohne Alle Dateien durchlaufen zu haben. Ist das Absicht? Falls nicht kannst du das leicht umgehen indem du ganz oben statt intTMP = 1 lieber intTMP = Sheets.count + 1 schreibst.

Gruß Mr. K.
0 Punkte
Beantwortet von
grad erst entdeckt, dass es zu diesem Thema ja
schon einen Thread gibt. Warum führst du
nicht den weiter?
...