' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub importTXT()
Dim strPath As String, strFile As String, strTemp As String
Dim lngNext As Long, lngFirst As Long, varLines As Variant
On Error GoTo ErrorHandler
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
strPath = "E:\Forum\Test\" 'Pfad - Anpassen!
If Right(strPath, 1) <> "\" Then strPath = strPath = "\"
strFile = Dir(strPath & "*.txt", vbNormal)
With Sheets("Tabelle1") 'Tabellenname - Anpassen!
lngFirst = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)
Do While strFile <> ""
lngNext = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)
strTemp = TextReadAll(strPath & strFile)
varLines = Split(strTemp, vbLf)
.Cells(lngNext, 1).Resize(UBound(varLines) + 1, 1) = varLines
strFile = Dir
Loop
lngNext = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)
.Range(.Cells(lngFirst, 1), .Cells(lngNext, 1)).TextToColumns Destination:=.Cells(lngFirst, 1), _
DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Other:=True, OtherChar:="_", _
FieldInfo:=Array(Array(1, 1), Array(2, 4), Array(3, 4)), _
TrailingMinusNumbers:=True
End With
ErrorHandler:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Private Function TextReadAll(ByVal FileName As String) As String
Dim FF As Integer, strText As String
On Error Resume Next
If ((GetAttr(FileName) And vbDirectory) <> vbDirectory) Then
FF = FreeFile
Open FileName For Binary As #FF
strText = Space$(LOF(FF))
Get #FF, , strText
Close #FF
TextReadAll = strText
End If
On Error GoTo 0
Err.Clear
End Function