Dim
dateien()
Option
Explicit
Sub
DateienLesen()
Call
EventsOff
Dim
DateiName
As
String
Dim
quelle
As
String
Dim
i
As
Long
Dim
j
As
Long
Dim
zeile
As
String
Dim
inhalt
Dim
ende
Dim
nr
ReDim
dateien(0)
dateien(0) = 0
quelle =
"Y:\Eigene Dateien\Bearbeitung\bearbeiten\makro\neu"
Call
txtsuchen(quelle)
If
dateien(0) = 0
Then
MsgBox
"Keine .txt Dateien gefunden!"
Else
For
i = 1
To
dateien(0)
DateiName = dateien(i)
ende = ActiveSheet.Cells(Rows.Count, 3).
End
(xlUp).Row
ende = ende + 2
nr = FreeFile()
Open DateiName
For
Input
As
#nr
Do
While
Not
EOF(nr)
Line Input #nr, zeile
inhalt = Split(zeile, Chr(9))
For
j = 0
To
UBound(inhalt)
If
IsNumeric(inhalt(j))
Then
inhalt(j) = Replace(inhalt(j),
","
,
"."
)
ActiveSheet.Cells(ende, 3 + j) = inhalt(j)
Next
j
ende = ende + 1
Loop
Close #nr
Next
i
End
If
ActiveSheet.Range(
"C:D"
).Columns.AutoFit
ActiveSheet.Range(
"C:D"
).NumberFormat =
"0.000000"
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
ChDrive (Left(quelle, 3))
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