VBA Liste in andere Arbeitsmappe kopieren

Question

Hallo zusammen,

ich möchte immer die aktuellste Excel Datei aus einem Ordner in eine neue Excel Liste kopieren habe hier einen Code in VBA geschrieben, aber ich bekomme immer die Fehler Meldung Else ohne If, weiß aber nicht wieso. kann mir einer von euch vielleicht weiter helfen? (Fehler ist unterstrichen)

hier der Code:


Option Explicit
Sub SmartHome()
Dim strTmpFileNew As String
Dim strTmpFile As String
Dim strPath As String
Dim StrTyp As String
Dim datTime As Date
Dim intTMP As Integer
Dim strFileName As String
On Error GoTo Fin
strPath = "A:\Projekte (laufende)\SmartHome\1_AP Liste\" ' Anpassen!!!!!
StrTyp = "*.xlsx"
intTMP = 1
strTmpFile = Dir$(strPath & StrTyp)
strTmpFileNew = strTmpFile
datTime = FileDateTime(strPath & strTmpFile)
Do While strTmpFile <> ""
If datTime < FileDateTime(strPath & strTmpFile) Then
datTime = FileDateTime(strPath & strTmpFile)
strTmpFileNew = strTmpFile
End If
strTmpFile = Dir$()
Loop
If strTmpFileNew <> "" Then Workbooks.Open strPath & strTmpFileNew
With ActiveWorkbook
.Worksheets(1).Copy _
After:=ThisWorkbook.Worksheets _
(ThisWorkbook.Worksheets.Count)
.Close False
With ThisWorkbook
.Worksheets(.Worksheets.Count).Name = "Liste" & intTMP
End With
intTMP = intTMP + 1
End With
strFileName = Dir$()
Else
strFileName = Dir$()
Fin:
If Err.Number <> 0 Then MsgBox "Error: " & _
Err.Number & " " & Err.Description
End Sub


VG
Simon

Answer 1

Hallo Simon,

falls das Else so gewollt ist, dann liegt der Fehler in der Zeile

If strTmpFileNew <> "" Then Workbooks.Open strPath & strTmpFileNew

Außerdem würde dann noch ein End If fehlen.
Richtig müsste die Codezeile dann so aussehen:

If strTmpFileNew <> "" Then
Workbooks.Open strPath & strTmpFileNew
..
Else
strFileName = Dir$()
End If

Falls das Else nicht gewollt ist, dann lösche den Teil

Else
strFileName = Dir$()

Gruß

M.O.

Answer 2

Hallo M.O

Danke für die Antwort!
Aber irgendwie funktioniert der Code generell nicht.

Deswegen meine Frage an die Profis:
Wie muss ich diesen Code:
Do While strFileName <> ""
If datTime < FileDateTime(strPath & strFile) Then
datTime = FileDateTime(strPath & strFile)
strFileNew = strFileName
End If
strFileName = Dir$()
Loop
If strFileNew <> "" Then Workbooks.Open strPath & strFileNew
Fin:
If Err.Number <> 0 Then MsgBox "Error: " & _
Err.Number & " " & Err.Description

In diesen Code:

Option Explicit
Public Sub Test()
Dim strFileName As String
Dim strFileNew As String
Dim strPath As String
Dim intTMP As Integer
Dim datTime As Date
On Error GoTo Fin
strPath = "C:\Temp\" ' anpassen!!!
Application.ScreenUpdating = False
intTMP = 1
strFileName = Dir$(strPath & "*.xlsx*")
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
Do While 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



einbinden, damit die Codes zusammen funktioniert.
Ich möchte, dass der immer die neueste Excel Datei aus einem Verzeichnis in eine andere Excel Liste kopiert.

[u]Beispiel:[/u ]Also sagen wir, ich habe ein Excel Datei von gestern in Ordner A und möchte diese in der Tabelle haben, in der ich das Makro ausführe.

VG
Simon

Answer 3

Hallo Simon,

versuch mal den folgenden Code:

Public Sub Test()
Dim strFileName As String
Dim strFileNew As String
Dim strPath As String
Dim datTime As Date

'Pfad der eingelesen werden soll - anpassen!!!!
strPath = "C:\Test\"

'Bildschirmaktualisierung ausschalten
Application.ScreenUpdating = False

'Prüfen ob Pfadangabe mit Backslash abschließt, ansonsten ändern
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"

'Nur Excel-Dateien einlesen
strFileName = Dir(strPath & "*.xl*")
Do While Len(strFileName)
'Datei nur bearbeiten, wenn diese nicht die aktuelle ist
If Not strFileName = ThisWorkbook.Name Then
'Prüfen, ob letztes Speicherdatum der Datei größer ist, als das in Variable
If datTime < FileDateTime(strPath & strFileName) Then
datTime = FileDateTime(strPath & strFileName) 'falls ja Speicherdatum in Variable schreiben
strFileNew = strFileName 'und Name der Datei in Variable schreiben
End If
End If
strFileName = Dir 'nächste Datei einlesen
Loop
'nun neuste Datei öffnen
Workbooks.Open (strPath & strFileNew)
'und das erste Arbeitsblatt in der Arbeitsmappe am Ende der aktuellen Mappe einfügen
With ActiveWorkbook
.Worksheets(1).Copy _
After:=ThisWorkbook.Worksheets _
(ThisWorkbook.Worksheets.Count)
.Close False 'geöffnete Mappe wieder schließen, ohne Speichern
End With
'eingefügtes umbenennen, hier mit Datum der gefundenen Mappe; ggf. anpassen
With ThisWorkbook
.Worksheets(.Worksheets.Count).Name = "Auftragsliste " & CDate(Fix(datTime))
End With

'Bildschirmaktualisierung wieder einschalten
Application.ScreenUpdating = True
End Sub

Gruß

M.O.

Answer 4

Hallo M.O,

vielen Dank! der code funktioniert!

Echt Klasse :D

VG
Simon