Hallo!

Kann hier in der Frühstückdspause das Bild nicht aufmachen. Weiß aber glaube ich was du meinst. Da extra noch eine Funtion einfügen wäre zuviel. :-) Bei der zweiten Variante würde es so gehen wie unten. Für die erste mit line input folgt dann gleich noch ein post. Weiß nicht genau, mit welcher Version du arbeiten willst. 

Gruß und gute Rutsch

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).Worksheets(1).Range(Workbooks(ausgang).Worksheets(1).Cells(ende, 6), Workbooks(ausgang).Worksheets(1).Cells(ende + ende2, 6)) = Workbooks(ausgang).Worksheets(1).Cells(ende, 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