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
Dim
utf
As
Boolean
Dim
prüfen
As
Boolean
Dim
erstezeile
As
Boolean
ReDim
dateien(0)
dateien(0) = 0
quelle =
" "
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()
utf =
False
prüfen =
False
erstezeile =
False
Open DateiName
For
Input
As
#nr
Do
While
Not
EOF(nr)
Line Input #nr, zeile
inhalt = Split(zeile, Chr(9))
If
prüfen =
False
Then
If
Len(inhalt(0)) > 2
Then
If
Asc(Left(inhalt(0), 1)) = 239
And
Asc(Mid(inhalt(0), 2, 1)) = 187
And
Asc(Mid(inhalt(0), 3, 1)) = 191
Then
utf =
True
End
If
prüfen =
True
End
If
For
j = 0
To
UBound(inhalt)
If
utf =
True
Then
If
erstezeile =
False
Then
If
j = 0
Then
inhalt(j) = Mid(inhalt(j), 4, Len(inhalt(j)))
If
IsNumeric(inhalt(j))
Then
inhalt(j) = Replace(inhalt(j),
","
,
"."
)
ActiveSheet.Cells(ende, 3 + j) = FromUTF8String(inhalt(j))
Else
If
IsNumeric(inhalt(j))
Then
inhalt(j) = Replace(inhalt(j),
","
,
"."
)
ActiveSheet.Cells(ende, 3 + j) = FromUTF8String(inhalt(j))
End
If
Else
If
IsNumeric(inhalt(j))
Then
inhalt(j) = Replace(inhalt(j),
","
,
"."
)
ActiveSheet.Cells(ende, 3 + j) = inhalt(j)
End
If
Next
j
erstezeile =
True
ende = ende + 1
Loop
Close #nr
Next
i
End
If
Call
tausch
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
Function
FromUTF8String(
ByVal
s
As
String
)
As
String
Dim
i
As
Integer
, b(2)
As
Byte
i = 1
s = s & Chr(0) & Chr(0)
Do
While
i <= Len(s) - 2
b(0) = Asc(Mid(s, i, 1))
b(1) = Asc(Mid(s, i + 1, 1))
b(2) = Asc(Mid(s, i + 2, 1))
If
(b(0)
And
&HE0) = &HE0
Then
FromUTF8String = FromUTF8String & ChrW((b(0)
And
&HF) *
CLng
(&H1000) + (b(1)
And
&H3F) *
CLng
(&H40) + (b(2)
And
&H3F))
i = i + 3
ElseIf
(b(0)
And
&HC0) = &HC0
Then
FromUTF8String = FromUTF8String & ChrW((b(0)
And
&H1F) * &H40 + (b(1)
And
&H3F))
i = i + 2
Else
FromUTF8String = FromUTF8String & Chr(b(0))
i = i + 1
End
If
Loop
End
Function
Function
tausch()
Dim
i
As
Long
For
i = 1
To
ActiveSheet.Cells(Rows.Count, 5).
End
(xlUp).Row
ActiveSheet.Cells(i, 5) = Replace(ActiveSheet.Cells(i, 5), Chr(195) & Chr(132),
"Ä"
)
ActiveSheet.Cells(i, 5) = Replace(ActiveSheet.Cells(i, 5), Chr(195) & Chr(164),
"ä"
)
ActiveSheet.Cells(i, 5) = Replace(ActiveSheet.Cells(i, 5), Chr(195) & Chr(150),
"Ö"
)
ActiveSheet.Cells(i, 5) = Replace(ActiveSheet.Cells(i, 5), Chr(195) & Chr(182),
"ö"
)
ActiveSheet.Cells(i, 5) = Replace(ActiveSheet.Cells(i, 5), Chr(195) & Chr(156),
"Ü"
)
ActiveSheet.Cells(i, 5) = Replace(ActiveSheet.Cells(i, 5), Chr(195) & Chr(188),
"ü"
)
ActiveSheet.Cells(i, 5) = Replace(ActiveSheet.Cells(i, 5), Chr(195) & Chr(159),
"ü"
)
Next
i
End
Function