Kopierbereich in VBA wirft Laufzeitfehler 1004

Question

Ich habe ein Makro geschrieben, das die ersten drei Spalten von Quell-Excel-Arbeitsmappen in ein Übersichtsblatt anfügt.

Der Code kopiert die nicht leeren Zellen in den ersten drei Spalten von der Registerkarte "Tabellendaten" der Quellarbeitsmappen beginnend mit dem Namen "Log * .xls" und fügt sie den Spalten in der Übersicht hinzu. Alle Daten in Zusammenfassungsblatt wird horizontal angehängt.

Jetzt funktioniert der Code völlig in Ordnung, wenn es ein paar hundert Zeilen von Daten in meiner Quelle xls ist (mit dem Namen „Log *“ ab)

Allerdings, wenn die „“ Log * .xsl“Dateien überspannen tausende, erhalte ich einen Laufzeitfehler, wenn Daten aus Quelldatei Bewältigungs

Fehler in Zeile:.

WorkBk.Worksheets("Tabular Data").Range("A1", Cells(lastRow, "C")).Copy 

Makro wie folgt:

Sub MergeAllWorkbooks() 

Dim SummarySheet As Worksheet 
Dim FolderPath As String 
Dim NRow As Integer 
Dim NextCol As Long 
Dim lastRow As Long 
Dim FileName As String 
Dim WorkBk As Workbook 


' Create a new workbook and set a variable to the first sheet. 
Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1) 

' Modify this folder path to point to the files you want to use. 
FolderPath = ThisWorkbook.Path 


' Call Dir the first time, pointing it to all Excel files in the folder path. 
FileName = Dir(FolderPath & "\" & "Log*.xls") 
NRow = 1 

' Loop until Dir returns an empty string. 
Do While FileName <> "" 



    ' Open a workbook in the folder 
    Set WorkBk = Workbooks.Open(FolderPath & "\" & FileName) 


    ' Find the last non-empty cell in the last row of col C from each Source sheet 
    ' Set the source range to be A:1 through C:lastrow 

    'lastRow = WorkBk.Worksheets("Tabular Data").Range("C" & Rows.Count).End(xlUp).Row 
    'Set SourceRange = WorkBk.Worksheets("Tabular Data").Range("A1:C" & lastRow).Copy 

    lastRow = WorkBk.Worksheets("Tabular Data").Range("A65536").End(xlUp).Row 
    WorkBk.Worksheets("Tabular Data").Range("A1", Cells(lastRow, "C")).Copy 


    If NRow = 1 Then 
     SummarySheet.Range("A65536").End(xlUp).PasteSpecial 
     NRow = NRow + 1 

    Else 
     NextCol = SummarySheet.Cells(1, Columns.Count).End(xlToLeft).Column 
     SummarySheet.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial 
     'SummarySheet.Range("A65536").End(xlUp).Offset(0, 1).PasteSpecial 

    End If 

    ' Close the source workbook without saving changes. 
    Application.CutCopyMode = False 
    WorkBk.Close savechanges:=False 

    ' Use Dir to get the next file name. 
    FileName = Dir() 


Loop 

' Call AutoFit on the destination sheet so that all 
' data is readable. 
SummarySheet.Columns.AutoFit 
SummarySheet.SaveAs (FolderPath & "\" & "Consolidated_Temp_Data.xls") 
MsgBox (NRow & " Files Read ") 

End Sub 

Bitte kann mir jemand helfen, was die Ursache und Lösung für mein Problem ist?

Vielen Dank im Voraus.

Answer 1

Code Änderung dieses

With WorkBk.Worksheets("Tabular Data") 
    .Range("A1", .Cells(lastRow, "C")).Copy 
End If