AW: txt-dateien einlesen, pdf-Druck, speichern
25.07.2013 17:31:24
Anna
Guten Abend Thorsten!
Ich hatte das Problem auch in einem anderen Forum gepostet, und habe von einem sehr netten Menschen eine Hilfe bekommen, die leider noch nicht ganz funktioniert. Jetzt zeigt er mir den Laufzeitfehler '9' an
Indes außerhalb des gültigen Bereichs.
Hier der Code, hast du eine Idee woran das liegen könnte oder ob etwas mit meinen txt-Dateien nicht stimmt?
Option Explicit
Public Sub Main()
'Wichtige Bedingungen:
' 1. Alle txt-Dateien in Ordner 1 müssen in Ordner 2 vorhanden sein!
' 2. Alle txt-Dateien mit gleichem Namen in Ordner 1 und Ordner 2 müssen die gleiche
' Länge haben.
' 3. Alle txt-Dateien müssen 5 Spalten besitzen
' 4. Keine der txt-Dateien hat eine Überschrift
' 5. Vor einem Wiederholten abruf sollten die bereits exportierten Dateien aus den Export
' -Ordnern gelöscht werden, da sonst bei jedem Speichern eine Frage kommt.
' 6. Die Angabe von Pfaden erfordert immer einen Backslash (\) am Ende.
' 7. SaveAsPDF speichert vorläufig noch als html-Datei, da Office 2003 keine PDF- _
Speicherung
' bietet. Dies kann ab Office 2007 angepasst werden.
' 8. Keiner der verwendeten Dateinamen darf einen Punkt ausser dem Trenner zur Dateinamens
' -erweiterung haben, da sonst falsche Dateien gespeichert werden.
' 9. Alle Verweise auf Ordner, Dateinamen, FileExtensions sind noch anzupassen!
Import
End Sub
Private Sub Import()
Dim sPfadInput1 As String
Dim sPfadInput2 As String
Dim i As Integer
Dim sFoundFile As String
Dim iFileNum As Integer
Dim sFileMuster As String
Dim aWertArray1() As Variant
Dim aWertArray2() As Variant
Dim aWertZeilen() As String
Dim aTemparray
Dim lZeilenAnzahl As Long
Dim fso As Object
Dim oFile As Object
Dim rInputRange1 As Range
Dim rInputRange2 As Range
Set rInputRange1 = Worksheets("Datenimport").Range("C3") 'erste Zelle des Zielbereichs 1
Set rInputRange2 = Worksheets("Datenimport").Range("I3") 'erste Zelle des Zielbereichs 2
sPfadInput1 = "C:\DATEN\test\Auswertung Modell\Datenimport\Feuchte 1\"
sPfadInput2 = "C:\DATEN\test\Auswertung Modell\Datenimport\Feuchte 2\"
sFileMuster = "*.txt"
sFoundFile = Dir(sPfadInput1 & sFileMuster)
If sFoundFile = "" Then
MsgBox "Keine Textdateien in Verzeichnis"
Exit Sub
End If
Do 'Schleife alle Textdateien
iFileNum = FreeFile
lZeilenAnzahl = GetNumberOfLines(sPfadInput1 & sFoundFile) 'Die Datei aus dem ersten _
Verzeichnis einlesen
ReDim aWertZeilen(lZeilenAnzahl - 1)
ReDim aWertArray1(lZeilenAnzahl, 3)
ReDim aWertArray2(lZeilenAnzahl, 3)
Set fso = CreateObject("Scripting.FileSystemObject")
Set oFile = fso.OpenTextFile(sPfadInput1 & sFoundFile)
i = 0
Do While oFile.AtEndOfStream True 'AlleDatenzeilen einlesen
aWertZeilen(i) = oFile.Readline
i = i + 1
Loop
For i = 0 To UBound(aWertZeilen) 'Die Datenzeilen in Spalten aufteilen
aTemparray = Split(aWertZeilen(i), vbTab)
aWertArray1(i, 0) = aTemparray(1) 'Die erste Spalte kann verworfen werden
aWertArray1(i, 1) = aTemparray(2)
aWertArray1(i, 2) = aTemparray(3)
aWertArray1(i, 3) = aTemparray(4)
Next i
Set oFile = fso.OpenTextFile(sPfadInput2 & sFoundFile) 'Die Datei aus dem zweiten _
Verzeichnis einlesen
i = 0
Do While oFile.AtEndOfStream True
aWertZeilen(i) = oFile.Readline
i = i + 1
Loop
For i = 0 To UBound(aWertZeilen) 'Die Datenzeilen in Spalten aufteilen
aTemparray = Split(aWertZeilen(i), vbTab)
aWertArray2(i, 0) = aTemparray(1) 'Die erste Spalte kann verworfen werden
aWertArray2(i, 1) = aTemparray(2)
aWertArray2(i, 2) = aTemparray(3)
aWertArray2(i, 3) = aTemparray(4)
Next i
'Die Arrays in die gewünschten Tabellenbereiche einfügen
rInputRange1.Resize(UBound(aWertArray1) + 1, 4) = aWertArray1
rInputRange2.Resize(UBound(aWertArray2) + 1, 4) = aWertArray2
'Als PDF speichern
SavePDF (sFoundFile)
'Als XLS speichern
SaveXLS (sFoundFile)
'Nächste Datei aus Verzeichnis holen
sFoundFile = Dir()
Loop While sFoundFile "" 'Wenn es keine Datei mehr gibt, sind wir durch.
End Sub
Private Sub SavePDF(sDateiName As String)
Dim sFixedPath As String
Dim sFixedExt As String
Dim sSaveName As String
Dim aFileNameArray
Dim tempWKB As Workbook
Dim aktWKB As Workbook
aFileNameArray = Split(sDateiName, ".") 'Die Dateiendung wegwerfen
sFixedPath = "C:\DATEN\test\Auswertung Modell\Datenexport\PDF\" 'Den Ausgabepfad festlegen
sFixedExt = ".htm" 'Die neue Dateiendung festlegen
sSaveName = sFixedPath & aFileNameArray(0) & sFixedExt
Set aktWKB = ActiveWorkbook
Set tempWKB = Workbooks.Add(xlWBATWorksheet)
tempWKB.Worksheets(1).Name = "Auswertung" 'Das eingefügte Blatt passend benennen
aktWKB.Worksheets("Auswertung").UsedRange.Copy 'Die Relevanten Daten aus dem Ursprungsblatt _
kopieren
tempWKB.Worksheets("Auswertung").Range("A1").PasteSpecial Paste:=xlPasteValues 'Die Werte _
Einfügen
tempWKB.Worksheets("Auswertung").Range("A1").PasteSpecial Paste:=xlPasteFormats 'Die _
Formate übertragen
tempWKB.SaveAs Filename:=sSaveName, FileFormat:=xlHtml 'Als PDF speichern
tempWKB.Close 'Schließen
End Sub
Private Sub SaveXLS(sDateiName As String)
Dim sFixedPath As String
Dim sFixedExt As String
Dim sSaveName As String
Dim aFileNameArray
sFixedPath = "C:\DATEN\test\Auswertung Modell\Datenexport\Excel\"
sFixedExt = ".xls" 'zunächst als Office 2003 - xls Datei
aFileNameArray = Split(sDateiName, ".") 'die alte Extension verwerfen
sSaveName = sFixedPath & aFileNameArray(0) & sFixedExt 'Speichernamen festlegen
ActiveWorkbook.SaveCopyAs sSaveName 'Kopie speichern (Achtung, inklusive Makros)
End Sub
Private Function GetNumberOfLines(ByVal strFile As String) As Long 'Hilfsfunktion um die anzahl _
benötigter Zeilen auszulesen.
Dim fso As Object
Dim ts As Object
Dim TempNum As Long
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.OpenTextFile(strFile)
ts.ReadAll
TempNum = ts.Line
Set ts = Nothing
Set fso = Nothing
GetNumberOfLines = TempNum
End Function
Beim Debuggen wird folgende Zeile im Sub markiert:
For i = 0 To UBound(aWertZeilen) 'Die Datenzeilen in Spalten aufteilen
aTemparray = Split(aWertZeilen(i), vbTab)
aWertArray2(i, 0) = aTemparray(1) 'Die erste Spalte kann verworfen werden
aWertArray2(i, 1) = aTemparray(2)
aWertArray2(i, 2) = aTemparray(3)
aWertArray2(i, 3) = aTemparray(4)
Next i
Ich hoffe du hast dir jetzt noch keine großen Umstände gemacht, wenn dann tut es mir leid, ich habe ne zeitlang keine Antworten bekommen und es in mehreren Foren probiert, in der Hoffnung, dass mir einer hilft.
VG Anna
