Option Explicit
Sub einlesen()
Dim strExt, ZuÖffnendeDatei, strPath, strFile
Dim Arr1() As String, Arr2() As String, i As Integer, x As Integer
strExt = "*.txt"
ZuÖffnendeDatei = Application.GetOpenFilename("Textdateien (" & strExt & "), " & strExt, _
Title:="Verzeichnisauswahl, erste Datei auswählen")
If ZuÖffnendeDatei = False Then Exit Sub
strPath = CurDir & "\"
If strPath = "" Then
Exit Sub
Else
Application.ScreenUpdating = False
ChDir strPath
Cells.Clear
strFile = Dir(strPath & strExt)
Do While Len(strFile) > 0
Arr1 = TextFileToArray(strFile)
For i = 23 To UBound(Arr1)
Arr2 = Split(Arr1(i), Chr(9))
x = Cells(Rows.Count, 1).End(xlUp)(2).Row
On Error Resume Next
Cells(x, 1).Resize(1, UBound(Arr2) + 1).Value = Arr2
On Error GoTo 0
Next i
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, _
Tab:=True, Semicolon:=False, Comma:=False, _
Space:=True, Other:=False, trailingMinusNumbers:=True
strFile = Dir()
Loop
Application.ScreenUpdating = True
End If
End Sub
Private Function TextFileToArray(ByVal strFileName As String) As Variant
Dim sWhole As String
Open strFileName For Input As #1
sWhole = Input$(LOF(1), 1)
Close #1
TextFileToArray = Split(sWhole, vbNewLine)
End Function