Daten aus anderem Excel kopieren_Teil2

Hallo zusammen,
mein alter Beitrag war zwar noch nicht erledigt, aber nicht mehr "noch offen", daher geht es wohl hier weiter...
Sub a()
Const PFAD$ = "G:\Aktuelle Woche_Einzelne Excel hier einfügen\"
Const WsQ$ = "Blatt_A" 'Quell-Blatt
Dim WbZ As Workbook: Set WbZ = ThisWorkbook
Dim WbQ As Workbook
Dim WsZ As Worksheet: Set WsZ = WbZ.Worksheets("Blatt_B") 'Ziel-Blatt
Dim Mappe
Application.ScreenUpdating = False
Mappe = Dir(PFAD & "*.xls*", vbNormal)
Do Until Mappe = vbNullString
Set WbQ = Workbooks.Open("Datei_A")
With WbQ.Worksheets(WsQ)
'A1:Qx, x = letzte gefüllte Zelle in Q
.Range("A1:Q" & .Cells(.Rows.Count, 17).End(xlUp).Row).Copy
With WsZ
'Einfügen ab nächster freier Zelle in A des Zielblattes
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial _
(xlPasteValuesAndNumberFormats)
End With
End With
WbQ.Close False
Mappe = Dir
Loop
Set WbZ = Nothing
Set WbQ = Nothing
Set WsZ = Nothing
End Sub
Grundsätzlich funktioniert es muss ich vorneweg sagen. Nur noch nicht in der Form, wie ich es gerne hätte. Folgende Fragen/Anliegen hätte ich noch:
1. Beim starten des Makros in der Zieldatei poppt die Eingabeaufforderung auf...

Es befindet sich eine grosse Menge von Informationen in der Zwischenablage. Wollen Sie diese Informationen später in andere Programme einfügen?

Und das 12 mal nacheinander nach Bestätigung. Der gewünschte zu importierende Bereich wird dann 12 mal unterneinander eingefügt. Ich wüsste zu gerne warum das passiert. Weil 12 Quelldateien im Quellordner sind?
2. Im anderen Thread wurde gesagt, dass per "*.xls*" ich das Problem umgehen kann, dass die Quelldateien einen fixen Dateinamen brauchen, sowie dass alle Dateien im Quellordner nacheinander importiert werden können. Jedoch funktioniert das Makro bisher nur mit einer Quelldatei, wenn ich diese explizit defniere ("Datei_A").
3. Ist es mögliche das Quellformat der Zellen zu importieren? Bisher wird nur Text, also der Zellinhalt normal importiert.
Vielen Dank für Eure Hilfe!
Gruss Major

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub a() Const PFAD$ = "G:\Aktuelle Woche_Einzelne Excel hier einfügen\" Const WsQ$ = "Blatt_A" Dim WbZ As Workbook: Set WbZ = ThisWorkbook Dim WbQ As Workbook Dim WsZ As Worksheet: Set WsZ = WbZ.Worksheets("Blatt_B") Dim Mappe Application.ScreenUpdating = False Mappe = Dir(PFAD & "*.xls*", vbNormal) Do Until Mappe = vbNullString Set WbQ = Workbooks.Open("Datei_A") With WbQ.Worksheets(WsQ) .Range("A1:Q" & .Cells(.Rows.Count, 17).End(xlUp).Row).Copy _ WsZ.Cells(WsZ.Rows.Count, 1).End(xlUp).Offset(1, 0) End With Application.CutCopyMode = False: WbQ.Close False: Mappe = Dir Loop Set WbZ = Nothing Set WbQ = Nothing Set WsZ = Nothing End Sub

Sub a() On Error GoTo Fehlerbearbeitung Const PFAD$ = "G:\Aktuelle_Woche_Einzelne_Excel_hier_einfügen\" Const WsQ$ = "Planungsmatrix" 'Quell-Blatt Dim WbZ As Workbook: Set WbZ = ThisWorkbook Dim WbQ As Workbook Dim WsZ As Worksheet: Set WsZ = WbZ.Worksheets("Planungen") 'Ziel-Blatt Dim Mappe Application.ScreenUpdating = False Mappe = PFAD & Dir(PFAD & "*.xls*", vbNormal) Do Until Mappe = vbNullString Set WbQ = Workbooks.Open(Mappe) With WbQ.Worksheets(WsQ) 'A1:Qx, x = letzte gefüllte Zelle in Q .Range("A1:Q" & .Cells(.Rows.Count, 17).End(xlUp).Row).Copy With WsZ 'Einfügen ab nächster freier Zelle in A des Zielblattes .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial _ (xlPasteValuesAndNumberFormats) End With End With WbQ.Close False Mappe = Dir Loop Set WbZ = Nothing Set WbQ = Nothing Set WsZ = Nothing Fehlerbearbeitung: MsgBox ("Fehler: " & Err.Number & " - " & Err.Description) End Sub

Hallo Michael,
okay sorry erstmal, meine mangelnden Kenntnisse führen manchmal zu Chaos in den Beiträgen... ich arbeite daran:
In ein Excel möchte ich aus x-beliebig vielen Exceldateien aus einem bestimmten Tabellenblatt einen bestimmten Ausschnitt importieren.
Der Ordner in dem sich die ca. 9 zu importierenden Exceldateien befinden hat immer den gleichen Namen: "Aktuelle_Woche_Einzelne_Excel_hier_einfügen"
Die Exceldateien darin haben beliebige Namen, müssen jedoch alle immer genutzt werden.
Quellblatt lautet: "Planungsmatrix"
Zielblatt lautet "Planungen" und das soll der Bereich sein, in den importiert wird... Von spalte A bis Q / Zeile 1 bis letzte, nicht leere, Zeile.
Der Import von dem ersten Excel funktioniert auch, wenngleich mit einer Eingebaeaufforderung vor dem Import... "Es befindet sich eine grosse Menge von Informationen in der Zwischenablage. Wollen Sie diese Informationen später in andere Programme einfügen?"
Die zweite, dritte, vierte Excel etc. .... im Quellordner führt er nicht mehr aus, mit der Meldung: "Fehler 1004..."Dateiname" wurde nicht gefunden...Überprüfen Sie die Rechtschreibung usw."
An der Rechtschreibung liegt es aber nicht, denn diese zweite, dritte, vierte Datei...findet er, sobald sie alleine im Quellordner stehen.
Weiterhin hatte ich die Frage ob man denn nicht nur den Text, sondern auch das Format kopieren/einfügen kann.
So sieht nun aktuell der Code aus:

Sub Einzelne_Excel_einfügen()
On Error GoTo Fehlerbearbeitung
Const PFAD$ = "G:\Aktuelle_Woche_Einzelne_Excel_hier_einfügen\"
Const WsQ$ = "Planungsmatrix" 'Quell-Blatt
Dim WbZ As Workbook: Set WbZ = ThisWorkbook
Dim WbQ As Workbook
Dim WsZ As Worksheet: Set WsZ = WbZ.Worksheets("Planungen") 'Ziel-Blatt
Dim Mappe
Application.ScreenUpdating = False
Mappe = PFAD & Dir(PFAD & "*.xls*", vbNormal)
Do Until Mappe = vbNullString
Set WbQ = Workbooks.Open(Mappe)
With WbQ.Worksheets(WsQ)
'A1:Qx, x = letzte gefüllte Zelle in Q
.Range("A1:Q" & .Cells(.Rows.Count, 17).End(xlUp).Row).Copy
With WsZ
'Einfügen ab nächster freier Zelle in A des Zielblattes
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial _
(xlPasteValuesAndNumberFormats)
End With
End With
WbQ.Close False
Mappe = Dir
Loop
Set WbZ = Nothing
Set WbQ = Nothing
Set WsZ = Nothing
Fehlerbearbeitung:
MsgBox ("Fehler: " & Err.Number & " - " & Err.Description)
Application.ScreenUpdating = True
End Sub

Gruss Major

Sub DatenAusDateienHolen() Const PFAD$ = "G:\Aktuelle_Woche_Einzelne_Excel_hier_einfügen\" 'Pfad zu den Dateien Const WSQUELL$ = "Planungsmatrix" 'Name Quell-Blatt Const WSZIEL$ = "Planungen" 'Name Ziel-Blatt Dim WbZ As Workbook: Set WbZ = ThisWorkbook Dim WsZ As Worksheet: Set WsZ = WbZ.Worksheets(WSZIEL) Dim WbQ As Workbook, Mappe$ With Application .ScreenUpdating = False .DisplayAlerts = False End With Mappe = Dir(PFAD & "*.xls*", vbDirectory) Do Until Mappe = vbNullString If Not Mappe = WbQ.Name Then Set WbQ = Workbooks.Open(PFAD & Mappe) With WbQ.Worksheets(WSQUELL) .Range("A1:Q" & .Cells(.Rows.Count, 17).End(xlUp).Row).Copy End With With WsZ .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteAll Application.CutCopyMode = False End With WbQ.Close False Mappe = Dir End If Loop WsZ.Activate With Application .ScreenUpdating = True .DisplayAlerts = True End With Set WbZ = Nothing Set WsZ = Nothing Set WbQ = Nothing End Sub

Sub DatenAusDateienHolen() Const PFAD$ = "G:\Aktuelle_Woche_Einzelne_Excel_hier_einfügen\" 'Pfad zu den Dateien Const WSQUELL$ = "Planungsmatrix" 'Name Quell-Blatt Const WSZIEL$ = "Planungen" 'Name Ziel-Blatt Dim WbZ As Workbook: Set WbZ = ThisWorkbook Dim WsZ As Worksheet: Set WsZ = WbZ.Worksheets(WSZIEL) Dim WbQ As Workbook, Mappe$ With Application .ScreenUpdating = False .DisplayAlerts = False End With Mappe = Dir(PFAD & "*.xls*", vbDirectory) Do Until Mappe = vbNullString If Not Mappe = WbZ.Name Then Set WbQ = Workbooks.Open(PFAD & Mappe) With WbQ.Worksheets(WSQUELL) .Range("A1:Q" & .Cells(.Rows.Count, 17).End(xlUp).Row).Copy End With With WsZ .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormats Application.CutCopyMode = False End With WbQ.Close False Mappe = Dir End If Loop WsZ.Activate With Application .ScreenUpdating = True .DisplayAlerts = True End With Set WbZ = Nothing Set WsZ = Nothing Set WbQ = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

Daten aus anderem Excel kopieren_Teil2

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Daten aus anderem Excel kopieren_Teil2

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread