Copy non adjacent data from multiple files into Master file

[jamesplant77]

Good morning.

I have VBA that allows me to aggregate data from multiple workbooks in a specified folder and then copy lots of non adjacent data from these workbooks to create a master data file.

It all works fine apart from it is only allowing me to copy a certain amount of cells, before the VBA returns a 1004 error.

This is the VBA:

ub copyNonAdjacentCellData()
Dim myFile As String, path As String
Dim NextRow As Long, col As Long

path = "C:\Users\JamesPlantCloud21\Desktop\Timesheets - STH Staff\"
'C:\Users\JamesPlantCloud21\Desktop\Timesheets - STH Staff
myFile = Dir(path & "*.xlsx")

Application.ScreenUpdating = False

Do While myFile <> ""
Workbooks.Open (path & myFile)
Windows(myFile).Activate

Set copyrange = Sheets("JAN 23").Range("C4,C5,C9,D9,E9,F9,G9,H9,I9,J9,K9,AQ9,AR9,AS9,AT9,C10,D10,E10,F10,G10,H10,I10,J10,K10,AQ10,AR10,AS10,AT10,C11,D11,E11,F11,G11,H11,I11,J11,K11,AQ11,AR11,AS11,AT11")

Windows("Timesheet_Aggregator_STH.xlsm").Activate

NextRow = ThisWorkbook.Sheets("STH_STAFF").Cells(Rows.Count, 1).End(xlUp).Row + 1


col = 1
For Each cell In copyrange
cell.Copy


Cells(NextRow, col).PasteSpecial xlPasteValues

col = col + 1

Next

Windows(myFile).Close SaveChanges:=False

myFile = Dir()

Loop

Range("A:CB").EntireColumn.AutoFit

Application.ScreenUpdating = True


End Sub

As you can see from the range, I am able to copy row 9,10 & 11 perfectly, but when I expand the range to include rows 12,13, & 14 I get the error. Is there a way that I could change to C9:K9,AQ9:AT9,C10:K10,AQ10,AT10 etc...

 

[dmt32]

Hi,
untested but see if this update to your code resolves the issue

Sub copyNonAdjacentCellData()
    Dim myFile                   As String, path As String
    Dim CopyMonth           As String
    Dim NextRow               As Long, col As Long
    Dim wbCopy                 As Workbook
    Dim wbDest                  As Worksheet
    Dim arr()                       As Variant
  
    path = "C:\Users\JamesPlantCloud21\Desktop\Timesheets - STH Staff\"
  
    CopyMonth = "JAN 23"
  
  
    'C:\Users\JamesPlantCloud21\Desktop\Timesheets - STH Staff
    myFile = Dir(path & "*.xlsx")
  
    On Error GoTo myerror
  
    Set wsDest = ThisWorkbook.Worksheets("STH_STAFF")
  
    Application.ScreenUpdating = False
  
    Do While myFile <> ""
  
        Set wbCopy = Workbooks.Open(path & myFile)
      
        Set copyrange = wbCopy.Worksheets(CopyMonth).Range("C4,C5,C9,D9,E9,F9,G9,H9,I9,J9,K9,AQ9,AR9,AS9,AT9,C10," & _
                                                           "D10,E10,F10,G10,H10,I10,J10,K10,AQ10,AR10,AS10,AT10," & _
                                                            "C11,D11,E11,F11,G11,H11,I11,J11,K11,AQ11,AR11,AS11,AT11")
        ReDim arr(1 To copyrange.Cells.Count)
      
        For Each cell In copyrange
            col = col + 1
            arr(col) = cell.Value
        Next cell
      
        With wsDest
            NextRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
            'post array to range
            .Cells(NextRow, 1).Resize(, UBound(arr)).Value = arr
        End With
      
        wbCopy.Close False
      
        myFile = Dir()
      
        Set wbCopy = Nothing
        Set copyrange = Nothing
        col = 0
    Loop
  
  
myerror:
    If Not wbCopy Is Nothing Then wbCopy.Close False
    Application.ScreenUpdating = True
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub

Dave