AW: Einlesen von großen Textdateien per VBA
05.01.2007 18:09:11
großen
Hallo
musste noch ein klein wenig umschreiben
Option Explicit
Sub Read_Big_File_Hold_Structure()
'(C) Ramses
Dim myFSO As Object, myFile As Variant, myTxtStream As Variant, myText As Variant
Dim i As Long, n As Byte, tarRow As Long, rowCounter As Long, txtLines As Long, impSheetNr As Integer
Dim tarWks As Worksheet, Text1 As Variant
Dim arrFieldStructure(), minFieldLen As Integer
Dim tmpString As String, partLen As Integer
'Dialog öffnen auf Basis von *.txt Files
myFile = Application.GetOpenFilename("TXT Files (*.txt),")
If myFile = "" Or myFile = False Then Exit Sub
'Für Fortschrittsanzeige
Open myFile For Input As #1
'Die anzahl ist nötig um die Grösse des Arrays zu deklarieren
'Zähler auf 0 setzen
txtLines = 0
Do While Not EOF(1) ' Schleife bis Dateiende.
Input #1, Text1 ' Hilfsvariable zum einlesen verwenden
'Zähler hochzählen
txtLines = txtLines + 1
Loop
'Schliessen der Datei weil Dateiende erreicht wurde
Close #1
'Feldstruktur definieren
arrFieldStructure = Array(16, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8)
impSheetNr = 1
Set myFSO = CreateObject("Scripting.FileSystemObject")
'Hier bitte den Dateinamen anpassen :
Set myFile = myFSO.GetFile(myFile)
Set myTxtStream = myFile.OpenAsTextStream(1)
'Datei bis zum Ende Einlesen
tarRow = 1
rowCounter = 1
ActiveSheet.Name = "Import_" & impSheetNr
Set tarWks = Worksheets(ActiveSheet.Name)
Application.ScreenUpdating = False
Debug.Print "Start: " & Time
x = Time
Do While Not myTxtStream.AtEndOfStream
If tarRow Mod 65536 <> 0 Then
Application.StatusBar = rowCounter & " von " & txtLines & " verarbeitet"
tmpString = myTxtStream.readline
tarWks.Cells(tarRow, 1) = Left(tmpString, arrFieldStructure(0))
partLen = arrFieldStructure(0)
For n = 1 To UBound(arrFieldStructure)
tarWks.Cells(tarRow, n + 1) = Mid(tmpString, partLen, arrFieldStructure(n))
partLen = partLen + arrFieldStructure(n)
Next n
If Len(tmpString) > partLen Then
tarWks.Cells(tarRow, tarWks.Cells(tarRow, 255).End(xlToLeft).Column) = Right(tmpString, Len(tmpString) - partLen)
End If
tarRow = tarRow + 1
rowCounter = rowCounter + 1
Else
impSheetNr = impSheetNr + 1
Worksheets.Add after:=Worksheets(ActiveSheet.Index)
With ActiveSheet
.Name = "Import_" & impSheetNr
End With
Set tarWks = Worksheets(ActiveSheet.Name)
tarRow = 1
rowCounter = rowCounter + 1
End If
Loop
Application.ScreenUpdating = True
myTxtStream.Close
Debug.Print "Ende: " & Time
Debug.Print "Import Dauer: " & Format(Time - x, "hh:mm:ss")
End Sub
Der Code benötigt bei mir für den Import von 250'000 Datensätzen/Zeilen (Habe den Inhalt deiner Datei einfach kopiert = 17.5 MB) 1 Min 57 Sek. und läuft einwandfrei durch.
Hoffentlich hilfts :-)
Gruss Rainer