Und hier die Version mit input line - sollte auch gehen!
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
Dim text As String
ReDim dateien(0)
dateien(0) = 0
quelle = " " 'Pfad eintragen
Call txtsuchen(quelle)
If dateien(0) = 0 Then
MsgBox "Keine .txt Dateien gefunden!"
Else
'Daten auslesen
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
text = inhalt(2)
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))
erstezeile = True
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
ActiveSheet.Cells(ende, 6) = text
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)
'Ordner durchschauen
suche = Dir(quelle & "\*.*", vbDirectory)
Do Until suche = ""
'Normale Dateien rausfiltern
If (GetAttr(quelle & "\" & suche) = 16) Then
'die hier ankommen, sind Ordner, extra speichern
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
'jetzt durch die Ordner gehen
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
|