Hallo Leute :) 

mein Ziel ist es aus einem selbst ausgewählten Ordner (Verzeichnis) in jenem mehrere Excel-Dateien abgespeichert sind (mit unterschiedlichem Namen, aber die Tabellenblätter sind gleich benannt) pro Datei folgengenden Vorgang zu haben = und zwar soll im ersten Schritt eine neue Excel-Datei (Workbook) erstellt werden, in welches dann das Tabellenblatt "Gross", welches aus der ersten Datei aus dem ausgewählten Ordner stammt, kopiert und umbenannt in "Brutto" werden soll und unter einem bestimmten Pfad (s.Code) abgespeichert werden soll. Danach erfolgt das selbe mit der zweiten Datei aus dem ausgewählten Ordnerverzeichnis bis keine Datei im Ordner mehr vorzufinden ist. Absgepeichert soll jede Datei basierend auf dem Dateinamen im Ordnerverzeichnis (pro Datei unterschiedich) in einem neuen Ordner. 

Hier der Code: 

Sub Transfer()
   Dim oTargetBook As Object
   Dim oSourceBook As Object
   Dim sPfad As String
   Dim sDatei As String
   Dim oFileDialog As FileDialog
   Dim sFileName As String

     Application.ScreenUpdating = False 'Das "Flackern" ausstellen
     Application.DisplayAlerts = False 'Keine Fehlermeldungen anzeigen

     'Schritt 1: Schleife über alle Excel-Dateien in einem ausgewählten Verzeichnis
     Set oFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
     With oFileDialog
        .Title = "Verzeichnis auswählen..."
        .ButtonName = "Import"
        If .Show = -1 Then sPfad = .SelectedItems(1)
     End With
     
     sDatei = Dir(CStr(sPfad & "*.xl*")) 'Alle Excel Dateien

      Do While sDatei <> ""

         'Schritt 2: Pro Datei im Verzeichnis eine neue Arbeitsmappe öffnen
         Set oTargetBook = Application.Workbooks.Add
         
         'Schritt 3: öffnen der Datei und Datenübertragung
         Set oSourceBook = Workbooks.Open(sPfad & sDatei, False, True) 'nur lesend öffnen
         
         'Es wird immer ein bestimmtes Tabellenblatt namens "Gross" kopiert und in die neu erstellte Arbeitsmappe mit dem Namen "Brutto" eingefügt.
         oSourceBook.Worksheets(Gross).Copy After:=oTargetBook.Worksheets(oTargetBook.Sheets.Count)
         ActiveSheet.Name = "Brutto"
         oSourceBook.Close SaveChanges:=False
         
         On Error Resume Next

        'Schritt 4: Automatisches Speichern unter und Namensvergabe
        
        'Arbeitsmappenname hängt von dem Dateinamen im ausgewählten Verzeichnis ab und wird automatisch unter einem bestimmten Pfad abgespeichert
         sFileName = Left(sDatei, InStrRev(sDatei, ".") - 1)
         
         ActiveWorkbook.SaveAs Filename:= _
         "C:\Users\Markus\Desktop\Excel makro\Target" & sFileName & ".xls" _
         , FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
         ReadOnlyRecommended:=False, CreateBackup:=False

         oTargetBook.Close

         'Wenn ein Fehler aufgetreten ist, wird dieser resettet
         If Err.Number <> 0 Then
            Err.Number = 0
            Err.Clear
         End If
         On Error GoTo 0

         'Nächste Datei
         sDatei = Dir()

     Loop

Beenden:
     Application.ScreenUpdating = True 'Das Bildschirm-Aktualisieren wieder einschalten
     Application.DisplayAlerts = True 'Fehlermeldungen wieder anzeigen
     
     If Trim(sPfad) = "" Then Exit Sub

     'Abschlussmeldung
     MsgBox "Fertig!"

     'Variablen aufräumen
     Set oTargetBook = Nothing
     Set oSourceBook = Nothing

End Sub

Vielen Dank im Voraus für eure Unterstützung :) 

lg