Sub Dateien_Auf_Speichern_Zu()
Dim Datei As String
Dim Arbeitsmappe As String
Dim PFAD As String
Dim rFind As Range
PFAD = InputBox("Geben Sie bitte den Ordner an der durchsucht werden soll")
Datei = Dir(PFAD & "*.xls")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While Datei <> ""
Application.Workbooks.Open Datei
Set rFind = Cells.Find(What:="Gesamt-UMSATZ", After:=Cells(1, 6), LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
rFind.Columns("e:n").Select
Selection.Copy
Sheets.Add
ActiveSheet.Paste
ActiveWorkbook.Close True
Datei = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub