VBA 不起作用（从一个文件复制数据并粘贴到最后一行数据下方的不同工作簿）

Question

Can somebody fix this for me? It breaks down at paste stage.

Sub GetFileCopyLabour()

   Dim Fname As String
   Dim SrcWbk As Workbook
   Dim DestWbk As Workbook
   Dim lDestLastRow As Long

   Set DestWbk = ThisWorkbook

   Fname = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", Title:="Select a File")
   If Fname = "False" Then Exit Sub
   Set SrcWbk = Workbooks.Open(Fname)

   lDestLastRow = DestWbk.Sheets("Labour Dump").Cells(DestWbk.Sheets("Labour Dump").Rows.Count, "A").End(xlUp).Offset(1).Row

   SrcWbk.Sheets("DATA DUMP").Range("A:AX").Copy DestWbk.Sheets("Labour Dump").Range("A:AX" & lDestLastRow)
   SrcWbk.Close False

End Sub

Answer 1

This works for me:

Sub GetFileCopyLabour()

    Dim Fname As String
    Dim SrcWbk As Workbook
    Dim DestWbk As Workbook
    Dim lDestLastRow As Long
    Dim SrcWbkLastRow As Long

    Set DestWbk = ThisWorkbook

    Fname = Application.GetOpenFilename(FileFilter:="Excel Files (.xls), .xls", Title:="Select a File")
    If Fname = "False" Then Exit Sub
    Set SrcWbk = Workbooks.Open(Fname)

    lDestLastRow = DestWbk.Sheets("Labour Dump").Cells(DestWbk.Sheets("Labour Dump").Rows.count, "A").End(xlUp).Offset(1).row
    SrcWbkLastRow = SrcWbk.Sheets("DATA DUMP").Cells.Find(what:="*", After:=SrcWbk.Sheets("DATA DUMP").Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).row

    SrcWbk.Sheets("DATA DUMP").Range("A1:AX" & SrcWbkLastRow).Copy
    DestWbk.Sheets("Labour Dump").Range("A" & lDestLastRow).PasteSpecial

    SrcWbk.Close False

End Sub

Answer 2

So here is my revised code, which works fine, apart from the two lines starting after paste special values. I'm trying to get formulas in cells AY2 and AZ2 to copy down the entire columns for the new data range, but currently it is only doing this for the first new row. Do you know how to fix? Code in question is sitting within double asterisks, which are not part of original code!

Sub GetFileCopyLabour()

Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False
Application.Calculation = False

Dim Fname As String Dim SrcWbk As Workbook Dim DestWbk As Workbook Dim lDestLastRow As Long

Set DestWbk = ThisWorkbook

Fname = Application.GetOpenFilename(FileFilter:="Excel Files (.xls), .xls", Title:="Select a File")
If Fname = "False" Then Exit Sub
Set SrcWbk = Workbooks.Open(Fname)

lDestLastRow = DestWbk.Sheets("Labour Dump").Cells(DestWbk.Sheets("Labour Dump").Rows.Count, "A").End(xlUp).Offset(1).Row

SrcWbk.Sheets("DATA DUMP").Range("A2:AX2000").Copy
DestWbk.Sheets("Labour Dump").Range("A" & lDestLastRow).PasteSpecial xlPasteValues
**DestWbk.Sheets("Labour Dump").Range("AY2:AZ2").Copy
DestWbk.Sheets("Labour Dump").Range("AY2:AZ" & lDestLastRow).FillDown**

SrcWbk.Close False


Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.AskToUpdateLinks = True
Application.Calculation = True

End Sub