When trying to copy range("A2:H2") End(xlDown) from multiple files into master Workbook

Run time error '424' Object Required

Sub Create()

Dim folderPath As String

Dim fileName As String

Dim erow As Long

Dim wbMaster As Workbook, wbTemp As Workbook

Dim wsMaster As Worksheet, wsTemp As Worksheet

folderPath= "\\Groups\DAILY RECON\October 2021"

Set wbMaster = ActiveWorkbook

Set wsMaster = wbMaster.Sheets("NY")


if Right(folderPath, 1)<> "\" Then folderPath = folderPath & "\"

fileName = Dir(folderPath & "*.xlsm")


With Application

    .ScreenUpdating = False

    .DisplayAlerts = False


End With



Do While fileName<>""

   if fileName <> "master.xlsm" Then

      Set wbTemp = Workbooks.Open(folderPath & fileName, ReadOnly= True)

      Set wsTemp = wbTemp.Sheets("NY")


   With wsMaster

      erow = .Range("A" & .Rows.Count).End(xlUp).Row

      ws.Temp.Range("A2:H2").Select  '  ----> **Error**

      Range(ActiveCell,ActiveCell.End(xlDown)).Select

      Selection.Copy

     .Range("A" & erow).Offset(1,0).PasteSpecial xlPasteValues


   End With


   wbTemp.Close False

   Set wsTemp = Nothing

   Set wbTemp = Nothing


   End If


   fileName = Dir


   Loop

   MsgBox "Finished"


   With Application

      .ScreenUpdating = True

      .DisplayAlerts = True

   End With



End Sub
  

   

CodePudding user response：

Copy Range From Multiple Files

Option Explicit

Sub Create()

    Dim wbMaster As Workbook, wbTemp As Workbook
    Dim wsMaster As Worksheet, wsTemp As Worksheet
    Dim mrg As Range, trg As Range
    Dim mrrg As Range
    Dim meRow As Long
    Dim mFileName As String, tFileName As String
    Dim tFolderPath As String
    
    Dim rCount As Long
    Dim cCount As Long
    
    tFolderPath = "\\Groups\DAILY RECON\October 2021"
    
    Set wbMaster = ActiveWorkbook ' ThisWorkbook ' workbook containing this code
    Set wsMaster = wbMaster.Sheets("NY")
    With wsMaster
        meRow = .Range("A" & .Rows.Count).End(xlUp).Row   1
        cCount = wsMaster.Columns("A:H").Columns.Count
        Set mrrg = .Range("A" & meRow).Resize(, cCount)
    End With
    mFileName = wbMaster.Name
    
    If Right(tFolderPath, 1) <> "\" Then tFolderPath = tFolderPath & "\"
    tFileName = Dir(tFolderPath & "*.xlsm")
    
    Application.ScreenUpdating = False
    
    Do While tFileName <> ""
        If StrComp(tFileName, mFileName, vbTextCompare) <> 0 Then
            Set wbTemp = Workbooks.Open(tFolderPath & tFileName, ReadOnly:=True)
            On Error Resume Next ' check if exists
                Set wsTemp = wbTemp.Sheets("NY")
            On Error GoTo 0
            If Not wsTemp Is Nothing Then ' it exists
                With wsTemp.Range("A1").CurrentRegion.Columns("A:H")
                    Set trg = .Resize(.Rows.Count - 1).Offset(1)
                End With
                rCount = trg.Rows.Count
                Set mrg = mrrg.Resize(rCount)
                mrg.Value = trg.Value
                Set mrrg = mrrg.Offset(rCount)
                Set wsTemp = Nothing
            End If
            wbTemp.Close SaveChanges:=False
        End If
        tFileName = Dir
    Loop
    
    Application.ScreenUpdating = True
    
    MsgBox "Finished"
    
End Sub