VBA to copy each sheet of a separate (open) workbook into destination workbook

[Texas Longhorn]

Hi All,

I am trying to write a macro that will cycle through each sheet in a source workbook (Historicals 2007_2011.xlsx), copy a range within each of those sheets, and paste values into a destination workbook (CombinedDataHist_20250318.xlsm). The source workbook, which is open while I am running the macro, has 60 worksheets. Using the first sheet as an example, I would like to copy the range from cell A15 to the cell in the last row of column EM (e.g., A15:EM1500). In the destination workbook, I would like to paste values. The first data block would be pasted in cell A2 of the destination workbook. When the macro cycles to the next sheet in the source workbook and returns to the destination workbook, the next block of data will be pasted below the previous block (in this example, cell A1488).

I have pasted my code below, which currently fails with a Run-time error '1004': Select method of Range class failed. When I enter the debugger, the line ws.Range("A10000").Select is highlighted. Unfortunately, my VBA is very rusty. I would greatly appreciate it if anyone could offer suggestions that (1) get my code working; and (2) help me clean up less-than-elegant lines like the aforementioned and Range("A1000000").Select.

Thank you.

Sub CopyTabs()


Dim wb As Workbook
Dim ws As Worksheet
Dim LastRow As Long

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
Set wb = Workbooks("Historicals 2007_2011.xlsx")

    For Each ws In wb.Worksheets
        ws.Range("A10000").Select
        LastRow = ws.Range("A:A").SpecialCells(xlCellTypeLastCell).Row
        Range("A15:EM" & LastRow).Copy
        Windows("CombinedDataHist_20250318.xlsm").Activate
        Range("A1000000").Select
        Selection.End(xlUp).Offset(1, 0).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Application.CutCopyMode = False

    Next ws


    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With



End Sub

 

[Texas Longhorn]

I gave up too quickly...by changing ws.Range("A10000").Select to two lines: ws.Activate followed by Range("A10000").Select, the code ran correctly. That said, I would still appreciate any thoughts on cleaning up my code. I'll leave the post up for a bit in hopes of suggestions before I mark it as SOLVED.

Thank you.

 

[MikeVol]

Hello @Texas Longhorn. Try next modification of your code:

Option Explicit

Sub CopyTabs()
    Dim ws          As Worksheet
    Dim lastRowDest As Long
    Dim lastRowSrc  As Long

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    Dim wbSource    As Workbook
    Set wbSource = Workbooks("Historicals 2007_2011.xlsx")

    Dim wbDest      As Workbook
    Set wbDest = Workbooks("CombinedDataHist_20250318.xlsm")

    Dim destSheet   As Worksheet
    Set destSheet = wbDest.Worksheets("Sheet1")   ' Replace with the desired sheet in the target workbook

    For Each ws In wbSource.Worksheets
        lastRowSrc = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
        lastRowDest = destSheet.Cells(destSheet.Rows.Count, "A").End(xlUp).Row + 1

        ws.Range("A15:EM" & lastRowSrc).Copy
        destSheet.Cells(lastRowDest, 1).PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
    Next ws

    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With

End Sub

Replace "Sheet1" with the actual name of the worksheet in the receiving workbook ("CombinedDataHist_20250318.xlsm"). I hope I helped you. Good luck.

 

[sofas]

Hello Texas Longhorn
Try this

Option Explicit
Sub CopyTabs()

    Dim wbSrc As Workbook, arr As Worksheet, wbDest As Workbook, wsDest As Worksheet
    Dim LastRow As Long, OnRng As Long, DataArr As Variant

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Set wbSrc = Workbooks("Historicals 2007_2011.xlsx")
    Set wbDest = Workbooks("CombinedDataHist_20250318.xlsm")
    Set wsDest = wbDest.Sheets(1)

    OnRng = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row + 1

    For Each arr In wbSrc.Worksheets
       
        LastRow = arr.Cells(arr.Rows.Count, "A").End(xlUp).Row
       
        If LastRow >= 15 Then
            DataArr = arr.Range("A15:EM" & LastRow).Value
            wsDest.Cells(OnRng, 1).Resize(UBound(DataArr, 1), UBound(DataArr, 2)).Value = DataArr
            OnRng = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row + 1
        End If

    Next arr

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    MsgBox "done", vbInformation

End Sub

 

[sofas]

Option Explicit

Sub CopyTabs()

    Dim wbSrc As Workbook, arr As Worksheet, wbDest As Workbook, wsDest As Worksheet
    Dim LastRow As Long, OnRng As Long, DataArr As Variant
    Dim FileName As String

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    FileName = "Historicals 2007_2011.xlsx"

    On Error Resume Next
    Set wbSrc = Workbooks(FileName)
    On Error GoTo 0

    If wbSrc Is Nothing Then MsgBox "The file " & FileName & _
        " is closed. Please open it and try again", vbExclamation, "Warning": Exit Sub
       
    Set wbDest = Workbooks("CombinedDataHist_20250318.xlsm")
    Set wsDest = wbDest.Worksheets("Sheet1")   ' Replace with the desired sheet in the target workbook

    OnRng = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row + 1

    For Each arr In wbSrc.Worksheets
       
        LastRow = arr.Cells(arr.Rows.Count, "A").End(xlUp).Row
       
        If LastRow >= 15 Then
            DataArr = arr.Range("A15:EM" & LastRow).Value
            wsDest.Cells(OnRng, 1).Resize(UBound(DataArr, 1), UBound(DataArr, 2)).Value = DataArr
            OnRng = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row + 1
        End If

    Next arr

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    MsgBox "Process completed successfully", vbInformation

End Sub

To avoid errors if the file is closed

 

[Texas Longhorn]

@MikeVol and @sofas, thank you both for your feedback. I'm always amazed by how helpful people are on this board. Your suggestions helped me clean up my code, and you also clued me into much more efficient ways to find the last row/last row plus 1. Many thanks!