Text-Datei importieren

Hallo,
die Frage tauchte nun mehrmals auf, habe aber in der Suche noch nichts passendes gefunden.
Ich möchte gerne eine Textdatei importieren.
Die Textdatei hat aber:
1) mehr als 65536 Zeilen
2) Die Daten in einer Zeile sind mit Tabstops und Leerzeichen getrennt.
(Konkret pro Zeile: Daten(1)_Leerzeichen_Daten(2)_Tabstop_Daten(3)_Tabstop_Daten(..)_Tabstop_Daten(n-1)_Tabstop_Daten(
Hier eine Beispielquelldatei: https://www.herber.de/bbs/user/34851.txt
)
Ich habe mir schon folgendes Beispiel
https://www.herber.de/bbs/user/23029.xls
dazu angeguckt, konnte es aber nicht an meine Verhältnisse anpassen.
In allen Excel-Tabellenblättern werden die Zeilen der Textdatei zeilenweise in eine Zelle geschrieben. Im letzten Tabellenblatt, trennt das VBA Modul die Daten, aber nicht nach dem Gewünschten. Mal trennt es bei Punkten , mal zwischen Zahlen.
Zudem fehlen beim Einlesen Daten (bspw.37391 von ingesamt 233998 Zeilen -
das Modul füllt 4 Tabellenblätter vollständig und hört dann auf - ).
Wie kann ich diese Mißstände beseitigen, zumal ich das Makro nicht ganz verstehe.
Für Hilfen wäre ich dankbar.
Gruß
Bernd

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub LangeTextDatLesenV1() Dim strPfad As String, strHelp1 As String Dim arrInput() As String Dim lngPos As Long, lngFileNum As Long, lngTab As Long Dim wksSheets As Worksheet strPfad = Application.GetOpenFilename("Textdateien (*.txt), *.txt") If strPfad = "" Or UCase(strPfad) = "FALSCH" Or UCase(strPfad) = "FALSE" Then Exit Sub lngFileNum = FreeFile() Open strPfad For Binary As #lngFileNum strHelp1 = Space(LOF(lngFileNum)) Get #lngFileNum, , strHelp1 arrInput = Split(strHelp1, vbCrLf) Close #lngFileNum Application.ScreenUpdating = False lngTab = 1 For lngPos = LBound(arrInput) To UBound(arrInput) ActiveSheet.Cells(lngTab, 1) = Replace(arrInput(lngPos), " ", vbTab) lngTab = lngTab + 1 If lngTab > 65536 Then ActiveWorkbook.Worksheets.Add after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count) lngTab = 1 End If Next lngPos For Each wksSheets In ActiveWorkbook.Worksheets wksSheets.Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _ Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _ :=Array(1, 1), TrailingMinusNumbers:=True wksSheets.Activate wksSheets.Cells(1, 1).Activate Next wksSheets Application.ScreenUpdating = True End Sub

Hallo Bernd
hier das Makro mit Anpassungen, die Testdaten werden bei mir (Excel97) korrekt eingelesen. Ob das auch mit den über 200000 Datenzeilen geht ? Sollte aber eigentlich.
mfg
Franz



Option Explicit

Option Base 1


Sub LargeFileImport()
Dim FileName As String
Dim FileNum As Integer
Dim ResultStr As String
Dim wsSheet As Worksheet
Dim strValues() As String
Dim lngRow As Long
Dim intSheet As Integer
Dim intCounter As Integer
FileName = Application.GetOpenFilename("Textdateien (*.txt), *.txt")
If FileName = "" Then End
FileNum = FreeFile()
Open FileName For Input As #FileNum
Application.ScreenUpdating = False
Workbooks.Add template:=xlWorksheet
lngRow = 1
intSheet = 1
Application.StatusBar = "Blatt " & intSheet & " wird eingelesen"
ReDim strValues(65536, 1)
Do While Seek(FileNum) <= LOF(FileNum)
Line Input #FileNum, ResultStr
If Left(ResultStr, 1) = "=" Then
strValues(lngRow, 1) = "'" & ResultStr
Else
strValues(lngRow, 1) = ResultStr
End If
If lngRow < 65536 Then
lngRow = lngRow + 1
Else
ActiveSheet.Range("A1:A65536") = strValues
ActiveWorkbook.Worksheets.Add after:=Worksheets(Worksheets.Count)
lngRow = 1
intSheet = intSheet + 1
ReDim strValues(65536, 1) 'Feld leeren
Application.StatusBar = "Blatt " & intSheet & " wird eingelesen"
End If
Loop
Close
ActiveSheet.Range("A1:A65536") = strValues
ReDim strValues(1) 'Feld leeren
intSheet = 0
For Each wsSheet In ActiveWorkbook.Worksheets
intSheet = intSheet + 1
Application.StatusBar = "Daten von Blatt " & intSheet & " werden bearbeitet"
With wsSheet
'Text in Spalten, Tab oder Space separiert
.Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
:=Array(1, 1)
.Range("A1").Select
End With
Next wsSheet
Application.ScreenUpdating = True
Application.StatusBar = "Fertig"
Application.StatusBar = False
End Sub

Sub LangeTextDatLesenV3() Dim strPfad As String, strHelp1 As String Dim arrInput() As String, arrHelp(65535, 0) Dim lngPos As Long, lngFileNum As Long, lngTab As Long Dim wksSheets As Worksheet strPfad = Application.GetOpenFilename("Textdateien (*.txt), *.txt") If strPfad = "" Or UCase(strPfad) = "FALSCH" Or UCase(strPfad) = "FALSE" Then Exit Sub Workbooks.Add template:=xlWorksheet lngFileNum = FreeFile() Open strPfad For Binary As #lngFileNum strHelp1 = Space(LOF(lngFileNum)) Get #lngFileNum, , strHelp1 arrInput = Split(strHelp1, vbCrLf) Close #lngFileNum Application.ScreenUpdating = False lngTab = 0 For lngPos = LBound(arrInput) To UBound(arrInput) arrHelp(lngTab, 0) = arrInput(lngPos) lngTab = lngTab + 1 If lngTab > 65535 Then ActiveWorkbook.ActiveSheet.Range("A1:A65536") = arrHelp ActiveWorkbook.Worksheets.Add after:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count) lngTab = 0 Erase arrHelp End If Next lngPos ActiveWorkbook.ActiveSheet.Range("A1:A65536") = arrHelp For Each wksSheets In ActiveWorkbook.Worksheets wksSheets.Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _ TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _ Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _ :=Array(1, 1), TrailingMinusNumbers:=True wksSheets.Activate wksSheets.Cells(1, 1).Activate Next wksSheets Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread