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
|