Hallo Kaba!

Schlage mich hier jetzt schon ne Weile rum. Problem ist, dass mit die Ausgangsdatei fehlt. Bei meinen Dateien im ANSI passt alles. Und meine Editoren geben kein MS-DOS an. Habe deshalb mal nen neuen Versuch anbei. Der geht nach dem ersetzen eigentlich nur die Spalte durch und sucht die "komischen Zeichen" und ersetzt die. ISt jetzt nicht die schönste Programmierung aber ein Versuch. :-) Wenn es möglich ist, kann du mal so eine ANSI und MSDOS txt Datei (mit Umlauten) hochladen. Dann könnte man direkt mit den Daten probieren. Wie immer den Pfad neu 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
    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