Mehr als 65536 Datensätze einlesen

Sub Read_Large_File_1()
'Liest csv und txt Datein mit mehr als 65536 Datensätzen ein
'und erstellt automatisch eine neu Arbeitsmappe und Worksheets
'Der eingelesene Text wird in Spalte 1 geschrieben
'Hilfsvariable für Anzahl Datensätze
Dim Text1 As String
'Variablen für den Array nötig
Dim txtlines As Long, i As Long, n As Long
'Neue Mappe und Variables Tabellenblatt deklarieren
Dim tWkb As Workbook, tWks As String
'Für Office97 muss das Array TextArr als String definiert werden
'Entdeckt duch Gerd Z aus dem Herber Forum
Dim textArr As String
Dim ReadFile As String
Dim OldStatusbar
'Dialog öffnen auf Basis von *.dat Files
ReadFile = Application.GetOpenFilename("CSV Files (*.csv;*.txt),")
'Schliessen einer geöffneten Datei
Close #1
'1. Öffnen der Datei
'Den Namen und Pfad bitte anpassen
Open ReadFile 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
'Erneutes Öffnen um zum Dateianfang zu kommen
Open ReadFile For Input As #1    ' Datei zum Einlesen öffnen.
'Array neu auf die Anzahl der Linien initialisieren
ReDim textArr(txtlines)
'Einlesen der Dateien in das Array
For i = 1 To txtlines
Input #1, textArr(i)
Next i
Close #1
'Arbeitsmappe erstellen und zuweisen
Workbooks.Add
Set tWkb = ActiveWorkbook
'Alles löschen bis auf eine Tabelle
'>> Kosmetik :-)
For i = Worksheets.Count To 2 Step -1
Application.DisplayAlerts = False
Worksheets(i).Delete
Application.DisplayAlerts = True
Next
OldStatusbar = Application.DisplayStatusBar
'Namen vergeben
Worksheets(1).Name = "Data1"
tWks = tWkb.Worksheets(1).Name
'Daten in aktuelles Sheet schreiben
n = 1
For i = 1 To txtlines
Application.StatusBar = "Datensatz " & i & " von " & txtlines & " wird eingelesen"
'Neue Tabelle anlegen wenn Zelle 65536 erreicht wurde
If i Mod 65536 = 0 Then
Columns(1).TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, Semicolon:=True, Space:=True, Other:=True, FieldInfo:=Array(1, 1)
tWkb.Worksheets.Add after:=ActiveSheet
ActiveSheet.Name = "Data" & i
tWks = ActiveSheet.Name
n = 1
End If
tWkb.Worksheets(tWks).Cells(n, 1) = textArr(i)
n = n + 1
Next i
MsgBox ReadFile & " mit " & txtlines & " Datensätzen vollständig eingelesen"
Application.DisplayStatusBar = OldStatusbar
End Sub