Hallo zusammen,

ich habe den untenstehenden Code, er läuft auch super, nur möchte ich aus den Ursprungsdateien nur Sheet 2 kopieren, und in der neuen Datei sollen auch nur die Werte eingetragen werden.

könnt ihr mir helfen?

Vielen Dank und   Grüße

Christian

Sub blaue_tabelle

Dim Zielarbeitsmappe As Object
Dim Quellenarbeistmappe As Object
Dim pfad As String
Dim datei As String

    'screenflakern aus
Application.ScreenUpdating = False

    'Fehlermeldungen aus
Application.DisplayAlerts = False

    'wo sollen die Dateien eingefügt werden
   
Set Zielarbeitsmappe = ActiveWorkbook

    'wo soll der Pfad eingegeben werden aus dem die Dateien kommen
pfad = InputBox("Pfad eingeben und ein \", "Pfad")

    'definition welche Dateitypen eingefügt werden
datei = Dir(CStr(pfad & "*xl*"))

    'so lange wiederholen bis alle Dateien aus dem Ordner din sind
Do While datei <> ""


Set quellenarbeitsmappe = Workbooks.Open(pfad & datei, False, True)
   
    'nur das zweite Sheet kopieren
quellenarbeitsmappe.Sheets(2).Copy after:=Zielarbeitsmappe.Sheets(Zielarbeitsmappe.Sheets.Count)

    'welchen Namen sollen die neuen Sheets bekommen, hier die gleichen wie im Ausgang
Zielarbeitsmappe.Sheets(Zielarbeitsmappe.Sheets.Count).Name = datei

    'Ausgangsdatei nach Kopiervorgang schließen
quellenarbeitsmappe.Close

    'Vorgang wiederholen
datei = Dir()
Loop

    'Bild aktualisieren wieder an
Application.ScreenUpdating = True

    'fehlermeldungen wieder an
Application.DisplayAlerts = True

    'Nachricht wenn fertig
MsgBox ("Die zusammenführung ist beendet")

Set Zielarbeitsmappe = Nothing
Set quellenarbeitsmappe = Nothing


End Sub