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

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: 05.11.2024 um 17: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)

...
    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:

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

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.

strPath = "D:\temp\"

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.

Set sz = ActiveWorkbook.ActiveSheet

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.

    wb.Sheets("Tabelle1").UsedRange.Copy   
    sz.Cells(nextRow, 1).PasteSpecial (xlPasteValues) 

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

Ich würde das schneller eher so machen:

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

So kommen auch nicht die Überschriften jedes mal mit rüber.

Gruß mik

Frage VB for Applications Entwicklung

Mehr von cberndt

Excel Zählewenn aus Formel Wertcberndt - 3 Kommentare

Dateinamen nach Zeichnen abschneiden - Batch-Shellcberndt - 9 Kommentare

Script zum XML Datei Umschreibencberndt - 12 Kommentare

Heiß diskutiert