Dim
dateien()
Option
Explicit
Sub
DateienLesen()
Call
EventsOff
Dim
DateiName
As
String
Dim
quelle
As
String
Dim
i
As
Long
ReDim
dateien(0)
dateien(0) = 0
quelle =
"C:\Tmp\test_txt"
Call
txtsuchen(quelle)
If
dateien(0) = 0
Then
MsgBox
"Keine .txt Dateien gefunden!"
Else
For
i = 1
To
dateien(0)
DateiName = dateien(i)
With
ActiveSheet.QueryTables.Add(Connection:=
"TEXT;"
& DateiName, Destination:=Range(
"C"
& ActiveSheet.Cells(Rows.Count, 3).
End
(xlUp).Row + 2))
.Name = DateiName
.FieldNames =
True
.RowNumbers =
False
.FillAdjacentFormulas =
False
.PreserveFormatting =
True
.RefreshOnFileOpen =
False
.RefreshStyle = xlInsertDeleteCells
.SavePassword =
False
.SaveData =
True
.AdjustColumnWidth =
True
.RefreshPeriod = 0
.TextFilePromptOnRefresh =
False
.TextFilePlatform = 1252
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter =
False
.TextFileTabDelimiter =
True
.TextFileSemicolonDelimiter =
False
.TextFileCommaDelimiter =
False
.TextFileSpaceDelimiter =
False
.TextFileColumnDataTypes = Array(1)
.Refresh BackgroundQuery:=
False
End
With
Next
i
End
If
Call
EventsOn
End
Sub
Public
Sub
EventsOff()
With
Application
.ScreenUpdating =
False
.EnableEvents =
False
.Calculation = xlCalculationManual
End
With
End
Sub
Public
Sub
EventsOn()
With
Application
.ScreenUpdating =
True
.EnableEvents =
True
.Calculation = xlCalculationAutomatic
End
With
End
Sub
Function
txtsuchen(quelle
As
String
)
Dim
suche
Dim
ordner()
Dim
i
As
Long
ReDim
ordner(0)
ordner(0) = 0
ChDir (quelle)
suche = Dir(quelle &
"\*.*"
, vbDirectory)
Do
Until
suche =
""
If
(GetAttr(quelle & "\" & suche) = 16)
Then
ordner(0) = ordner(0) + 1
ReDim
Preserve
ordner(ordner(0))
ordner(ordner(0)) = suche
Else
If
Right(suche, 4) =
".txt"
Then
dateien(0) = dateien(0) + 1
ReDim
Preserve
dateien(dateien(0))
dateien(dateien(0)) = quelle & "\" & suche
End
If
End
If
suche = Dir()
Loop
For
i = 1
To
UBound(ordner)
If
Dir(ordner(i), vbNormal) =
""
And
Left(ordner(i), 1) <>
"."
Then
Call
txtsuchen(quelle & "\" & ordner(i))
ChDir (quelle)
End
If
Next
End
Function