Hallo Jörg!

Hier mal ein Version die bei mir läuft.  Dabei aber beachten, dass über DIR() die Reihenfolge der Dateien nicht eindeutig bestimmt ist. SIe kommen also nicht unbedingt in der Reihenfolge, wie du sie im Ordner sieht. Bei mir bisher immer in umgekehrter Reihenfolge. Auerdem wird nur bis zur Zeile R kopiert. Alles darüber (sollte ja wie du schreibst nicht passieren) wird ignoriert. Ich habe noch ein paar Kommentare mehr reingemacht. Bei Fragen, einfach nochmal melden.

Gruß Matthias

Option Explicit
Sub auslesen()
Dim pfad As String
Dim datei As String         'Dateiname der erstellten Datei
Dim sheet As String         'Tabellenblatt in datei
Dim zeilequelle As Integer  'letzte beschrieben Zeile im Sheet
Dim speicherort
Dim struktur As Object
Dim ausgang As String       'Datei mit Code
Dim ziel As String          'Tabelleblatt in die eingetragen wird
Dim zeileziel As Integer    'letzte beschriebene Zeile in ziel
Dim zeileneu As Integer     'hilfsvariable zur Ermittlung der letzten Zeile
Dim i As Long               ' Variable zum zählen

Application.ScreenUpdating = False

'************Daten festlegen***********************************
'Ausgangsdatei wichtig fürs einfügen
' Datei aus der der Code läuft
ausgang = "Statistik September 2015.xlsm"   'oder ThisWorkbook.name

' Name des Tabellenblattes, in das eingegügt werden soll
ziel = "Ausgabe"

'die letzte Zeile in Ausgabe suchen
zeileziel = 0
zeileneu = 0
For i = 1 To 11 ' von Spalte A bis R
    zeileneu = Workbooks(ausgang).Worksheets(ziel).Cells(Rows.Count, i).End(xlUp).Row
    If zeileziel < zeileneu Then zeileziel = zeileneu
Next i
' wenn schon was drin stand dann eine Zeile frei und neu eintragen, sonst in die erste Zeile
If zeileziel > 1 Then zeileziel = zeileziel + 2


'************Öffnen der Datei und Auslesen**************************

'das hier wäre die Alternative, hier würde man über den Ordner aussuchen können
MsgBox "Bitte im nächsten Fenster den entsprechenden Ordner auswählen und mit OK bestätigen!"
Set struktur = Application.FileDialog(msoFileDialogFolderPicker)
With struktur
    .Title = "Pfad suchen"
    '.InitialFileName = "Y:\Eigene Dateien"  'Anfangsordner für suche, kann man einstellen muss es aber nicht
                If .Show = -1 Then
                   For Each speicherort In .SelectedItems
                          pfad = speicherort
                   Next speicherort
                End If
End With
'in pfad ist nun der Pfad zu den TXT Dateien
 
 
'prüfen ob am Ende ein \ vom Pfad existiert, wenn nicht anhängen
If Right(pfad, 1) <> "\" Then pfad = pfad & "\"
 
'hier wird gesucht, ob de Pfad existiert und dort txt Dateien vorhanden sind, die letzte wird angezeigt, andere Dateitypen werden ignoriert
datei = Dir(pfad & "*.txt")

'in Datei ist nun entweder ein Dateiname oder wenn keine solche Datei existiert ""
' bei Dateinamen in die Schleife gehen und in Excel einfügen, ansonsten passiert nichts
Do While datei <> ""

    'festlegen des Blattnamens
    sheet = Left(datei, Len(datei) - 4)
    ' Filename ist der Pfad zu den TXT Dateien verkettet mit Dateiname, hierfür war das einfügen von \ notwendig, sonst gibt es einen Fehler
    Workbooks.OpenText Filename:=pfad & datei, Semicolon:=True
    
    'letzte beschrieben Zeile in Spalte  bis R suchen
    zeilequelle = 0
    zeileneu = 0
    For i = 1 To 11
        zeileneu = Workbooks(datei).Worksheets(sheet).Cells(Rows.Count, i).End(xlUp).Row
        If zeilequelle < zeileneu Then zeilequelle = zeileneu
    Next i
     
    'Bereich A1 bis RlezteZeile kopieren
    Workbooks(datei).Worksheets(sheet).Range(Workbooks(datei).Worksheets(sheet).Cells(1, 1), Workbooks(datei).Worksheets(sheet).Cells(zeilequelle, 18)).Copy
    
    ' Zieldatei wieder aktivieren
    Workbooks(ausgang).Activate
    'Daten einfügen
    Workbooks(ausgang).Worksheets(ziel).Cells(zeileziel, 1).PasteSpecial
    'Namen einfügen
    Workbooks(ausgang).Worksheets(ziel).Cells(zeileziel, 19) = datei
    'nächste Zeile in der Zieldatei festlegen
    zeileziel = zeileziel + zeilequelle + 2
    'erste Spalte der Zeile aktivieren
    Workbooks(ausgang).Worksheets(ziel).Cells(zeileziel, 1).Select
    'verhindern das Frage zur Zwischenabalge kommt
    Application.CutCopyMode = False
    
    'erstellte datei wieder löschen
    Workbooks(datei).Close savechanges:=False
   
    datei = Dir   'ruft das nächste Element auf, wenn es eins gibt steht in datei wieder der Name sonst halt ""
    
Loop

Application.ScreenUpdating = True
End Sub