VBA: mehrere Dateien nacheinander einlesen
06.12.2012 11:06:13
H.Benitz
da meine VBA-Kenntnisse zur Zeit noch recht bescheiden sind, habe ich mir das Script für mein Vorhaben aus verschiedenen Beiträgen zusammengebastelt.
Funktioniert soweit schon ganz gut, aber ein Problem gibt es noch!
Das Ziel ist:
Es sollen aus einem vom Anwender vorgegebenen Ordner alle (ASCII-)Files mit gleichem Teilnamen und gleichen Typs geöffnet und bestimmte Stellen darin gesucht und in ein Excel-Sheet übertragen werden.
Das funktioniert, wie gesagt, schon Alles.
Warum aber bricht Excel die Verarbeitung nach dem 6. File mit Fehlermeldung "Laufzeitfehler 53 - Datei nicht gefunden!" ab?
Es sind im gewählten Ordner mehr Files mit den eingestellten Kriterien vorhanden.
Ich bin für jede Hilfe dankbar.
Sub Fertigmelden(JOBNUM)
Dim strFile As String
Dim JOBNUMMER As String
Dim DATUM As String
Dim ZEIT As String
Dim PROGRAMMIERER As String
Dim TEILENAME As String
Dim AUFTRAGSNUMMER As String
Dim POS As String
Dim BEMERKUNG As String
Dim rcount As Long
Dim fso As Object, TextDat As Object
strPath = "W:\u\SFA\JOBDATA\" & JOBNUM & "\PLAT_?"
strExt = "*.DAT"
If strPath = "" Then
Exit Sub
Else
rcount = 4
strFile = Dir(strPath & strExt)
Do While Len(strFile) > 0
Set fso = CreateObject("Scripting.FileSystemObject")
Set TextDat = fso.OpenTextFile(strFile, 1, False)
Do While TextDat.AtEndOfStream True
Text = TextDat.ReadLine
If Mid(Text, 2, 11) = "JOB_DATA_1 " Then
JOBNUMMER = Mid(Text, 25, 5)
Cells(2, 1) = JOBNUMMER
End If
If Mid(Text, 2, 4) = "DATE" Then
DATUM = Mid(Text, 25, 10)
Cells(2, 2) = DATUM
End If
If Mid(Text, 2, 4) = "TIME" Then
ZEIT = Mid(Text, 25, 5)
Cells(2, 3) = ZEIT
End If
If Mid(Text, 2, 4) = "USER" Then
PROGRAMMIERER = Mid(Text, 25, 30)
Cells(2, 4) = PROGRAMMIERER
End If
If Mid(Text, 2, 15) = "PLATE_PART_NAME" Then
TEILENAME = Mid(Text, 25, 45)
Cells(rcount, 1) = TEILENAME
End If
If Mid(Text, 2, 16) = "PLATE_PART_ORDER" Then
AUFTRAGSNUMMER = Mid(Text, 25, 5)
Cells(rcount, 2) = AUFTRAGSNUMMER
End If
If Mid(Text, 2, 19) = "PLATE_PART_POSITION" Then
POS = Mid(Text, 25, 5)
Cells(rcount, 3) = POS
End If
If Mid(Text, 2, 18) = "PLATE_PART_REMARK " Then
BEMERKUNG = Mid(Text, 25, 40)
Cells(rcount, 4) = BEMERKUNG
rcount = rcount + 1
End If
Loop
MsgBox (strFile)
' Workbooks(strFile).Close
TextDat.Close
strFile = Dir() ' nächste Datei
Loop
End If
End Sub
Beste Grüße
Heiko