Option Explicit
Sub auslesen()
Dim pfad As String
Dim datei As String
Dim sheet As String
Dim zeilequelle As Integer
Dim speicherort
Dim struktur As Object
Dim ausgang As String
Dim ziel As String
Dim zeileziel As Integer
Dim zeileneu As Integer
Dim i As Long
Application.ScreenUpdating = False
ausgang = "Statistik September 2015.xlsm"
ziel = "Ausgabe"
zeileziel = 0
zeileneu = 0
For i = 1 To 11
zeileneu = Workbooks(ausgang).Worksheets(ziel).Cells(Rows.Count, i).End(xlUp).Row
If zeileziel < zeileneu Then zeileziel = zeileneu
Next i
If zeileziel > 1 Then zeileziel = zeileziel + 2
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"
If .Show = -1 Then
For Each speicherort In .SelectedItems
pfad = speicherort
Next speicherort
End If
End With
If Right(pfad, 1) <> "\" Then pfad = pfad & "\"
datei = Dir(pfad & "*.txt")
Do While datei <> ""
sheet = Left(datei, Len(datei) - 4)
Workbooks.OpenText Filename:=pfad & datei, Semicolon:=True
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
Workbooks(datei).Worksheets(sheet).Range(Workbooks(datei).Worksheets(sheet).Cells(1, 1), Workbooks(datei).Worksheets(sheet).Cells(zeilequelle, 18)).Copy
Workbooks(ausgang).Activate
Workbooks(ausgang).Worksheets(ziel).Cells(zeileziel, 1).PasteSpecial
Workbooks(ausgang).Worksheets(ziel).Cells(zeileziel, 19) = datei
zeileziel = zeileziel + zeilequelle + 2
Workbooks(ausgang).Worksheets(ziel).Cells(zeileziel, 1).Select
Application.CutCopyMode = False
Workbooks(datei).Close savechanges:=False
datei = Dir
Loop
Application.ScreenUpdating = True
End Sub