Also guten Morgen! Kam noch nicht dazu mir die Bilder / Dateien anzuschauen. Habe aber mal noch ne andere Möglichkeit gebastelt :-) - bei der man wieder einstellen kann, was die Quelle für ein Format hat - geht evtl. ein wenig langsamer. Hab aber noch nicht das passende Format  für alles gefunden. Deshalb läuft unten wieder der Tausch. Und was ober peinlich ist. Tausche mal bitte im letzten Code, wo bis zu 99 % alles lief  :-), in der letzten Zeile der Function tausch am Ende das ü in ein ß (also wo die Werte 195 / 159 stehen). Mano. Hatte mich da veschrieben. Und wenn es nur noch das ß war, sollte es dann auch klappen. In der  Version unten ist das schon behoben. Werde mir dann erstmal die Dateien nicht anschauen. :-) Und keine Angst, das Problem hat meinen Ehrgeiz geweckt. Das geht also schon in Ordnung. Schon mal guten Rutsch und hoffentlich passt es nun. 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 ende2
    Dim name As String
    Dim ausgang As String
    
    On Error Resume Next
    
    ReDim dateien(0)
    dateien(0) = 0
    ausgang = ThisWorkbook.name
    
    quelle = "C:\Users\ich\Desktop\Programmieung\hallo\Neuer Ordner\neu" '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
                
        Workbooks.OpenText Filename:=DateiName, Origin:=1252
        
        name = ActiveWorkbook.name
        
        ende2 = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
        
        ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(ende2, 3)).Copy Destination:=Workbooks(ausgang).Worksheets(1).Range(Workbooks(ausgang).Worksheets(1).Cells(ende, 3), Workbooks(ausgang).Worksheets(1).Cells(ende + ende2, 5))
                
        Workbooks(ausgang).Activate
        
        Workbooks(name).Close SaveChanges:=False
                
        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 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