So hier eine Version die prüft ob utf8 vorliegt oder halt ansi. je nachdem sollt dann die Eintragung erfolgen. Den Pfad vorher noch eintragen. Gruß
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 = " " '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
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
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
|