VBA Excel Dateien zusammenfassen
Hi Leute.
Ich bin dabei einen Ordner mit Excellisten zusammenzufassen. Im Ordner sind gut 600 einzelne Excel Dateien die immer nur Zeile mit überschriften haben und dann die Werte dazu. Die Daten will ich in einer Datei zusammenfassen (Spalten stimmen überein)
Hierfür habe ich folgendes Makro in Excel
folgendes Problem habe ich! Wenn ich es ausführe kommt ein Laufzeitfehler 1004: "Die Paste-Methode des Worksheet-Objektes konnte nicht ausgeführt werden."
Woran kann das liegen?? Ich bin leider komplett ohne Erfahrung in Sachen Makros und will eigentlich nur die Dateien zusammenfasen.
Ich bin dabei einen Ordner mit Excellisten zusammenzufassen. Im Ordner sind gut 600 einzelne Excel Dateien die immer nur Zeile mit überschriften haben und dann die Werte dazu. Die Daten will ich in einer Datei zusammenfassen (Spalten stimmen überein)
Hierfür habe ich folgendes Makro in Excel
Sub ZusammenkopierMakro()
'Pfad in dem die Excel-Dateien liegen
strPath = "D:\daten\*.xls"
strSammelmappe = ActiveWorkbook.Name
ActiveSheet.UsedRange
Range("A1").Select
strFile = Dir(strPath)
Do Until strFile = ""
Workbooks.Open Filename:=strFile
Selection.CurrentRegion.Select
Selection.Copy
ActiveWindow.Close
Windows(strSammelmappe).Activate
ActiveSheet.Paste
strFile = Dir()
nextRow = Cells.SpecialCells(xlLastCell).Row + 1
Range("A" & nextRow).Select
Loop
End Sub
folgendes Problem habe ich! Wenn ich es ausführe kommt ein Laufzeitfehler 1004: "Die Paste-Methode des Worksheet-Objektes konnte nicht ausgeführt werden."
Woran kann das liegen?? Ich bin leider komplett ohne Erfahrung in Sachen Makros und will eigentlich nur die Dateien zusammenfasen.
Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben
Content-ID: 325701
Url: https://administrator.de/contentid/325701
Ausgedruckt am: 22.11.2024 um 14:11 Uhr
3 Kommentare
Neuester Kommentar
Hi,
Du darfst meines Wissens die Quell-XLS erst schließen, wenn die Daten kopiert sind.
E.
Also z.B. (nicht getestet und/oder Sinnhaftigkeit geprüft)
Du darfst meines Wissens die Quell-XLS erst schließen, wenn die Daten kopiert sind.
E.
Also z.B. (nicht getestet und/oder Sinnhaftigkeit geprüft)
...
Workbooks.Open Filename:=strFile
Selection.CurrentRegion.Select
Selection.Copy
Set ActWin = ActiveWindow
Windows(strSammelmappe).Activate
ActiveSheet.Paste
strFile = Dir()
nextRow = Cells.SpecialCells(xlLastCell).Row + 1
Range("A" & nextRow).Select
ActWin.Close
...
Guten Morgen - hier mein Vorschlag zur Lösung deines Problems:
dient dazu, dass das Programm im Falle eines Fehlers dir die Fehlermeldung anzeigt, aber auch die geöffneten Objekte wieder beendet. Sonst bleiben nach einigen fehlerhaften Ausführungen unzählige offene Excel im Taskmanager.
Hier bitte den Pfad zu deinen Dateien anpassen. Die Datei, die das Makro enthält sollte nicht im selben Pfad liegen. Den \ am Ende nicht vergessen, ich habe in diesem Fall keine Fehlerprüfung eingebaut.
In dieses Tabellenblatt werden die Daten eingefügt, die aus den anderen Mappen kopiert werden. In diesem Fall das aktuelle Workbook (mit dem Makro) und das aktuell gewählte Tabellenblatt.
Den Tabellenblattnamen (hier "Tabelle1") an den Namen deines Tabellenblattes anpassen (aus dem die Daten kopiert werden sollen). Es wird der entsprechende Bereich kopiert und in das vorher definierte Tabellenblatt eingefügt. Dabei werden nur die Werte übernommen (keine Formate etc.). Ggf. an eigene Bedürfnisse anpassen.
Ich würde lieber mit ..Copy Destination:=sz.Range("A" & nextRow) arbeiten. Das wollte bei mir aber nicht laufen. Hat jemand eine Idee, warum diese Funktion über verschiedene Workbooks hinweg nicht läuft? Bleibe ich im gleichen Workbook, läuft es ohne Probleme.
Sollten noch Fragen sein, einfach melden.
Grüße
Sub collectSheets()
On Error GoTo damn
Dim ap As Excel.Application
Dim wb As Excel.Workbook
Dim sz As Excel.Worksheet
Dim strPath As String, strFile As String
Dim nextRow As Long
strPath = "D:\temp\"
strFile = Dir(strPath)
' Ziel (current WB)
Set sz = ActiveWorkbook.ActiveSheet
Set ap = CreateObject("Excel.Application")
nextRow = 1
Do Until strFile = ""
Set wb = ap.Workbooks.Open(Filename:=strPath & strFile, ReadOnly:=True)
wb.Sheets("Tabelle1").UsedRange.Copy
sz.Cells(nextRow, 1).PasteSpecial (xlPasteValues)
Application.DisplayAlerts = False
wb.Close
Application.DisplayAlerts = True
nextRow = sz.Cells.SpecialCells(xlLastCell).Row + 1
strFile = Dir()
Loop
damn:
If Err.Number <> 0 Then MsgBox Err.Description
' Aufräumen
Application.DisplayAlerts = False
Set wb = Nothing
ap.Quit
Set ap = Nothing
End Sub
On Error GoTo damn
strPath = "D:\temp\"
Set sz = ActiveWorkbook.ActiveSheet
wb.Sheets("Tabelle1").UsedRange.Copy
sz.Cells(nextRow, 1).PasteSpecial (xlPasteValues)
Ich würde lieber mit ..Copy Destination:=sz.Range("A" & nextRow) arbeiten. Das wollte bei mir aber nicht laufen. Hat jemand eine Idee, warum diese Funktion über verschiedene Workbooks hinweg nicht läuft? Bleibe ich im gleichen Workbook, läuft es ohne Probleme.
Sollten noch Fragen sein, einfach melden.
Grüße
Ich würde das schneller eher so machen:
So kommen auch nicht die Überschriften jedes mal mit rüber.
Gruß mik
Sub MergeWorksheets()
Const FOLDER = "D:\daten"
Dim sh As Worksheet
Application ScreenUpdating = False
Application DisplayAlerts = False
With ActiveSheet
file = Dir(FOLDER & "\*.xlsx")
While file <> ""
Set sh = GetObject(file).Sheets(1)
sh.UsedRange.Offset(1, 0).Resize(sh.UsedRange.Rows.Count - 1).Copy Destination:=.Cells(.Cells.SpecialCells(xlCellTypeLastCell).Row + 1, 1)
sh.Parent.Close False
isFirst = False
file = Dir()
Wend
End With
Application ScreenUpdating = True
Application DisplayAlerts = True
End Sub
Gruß mik