pull data from files without open them

Halk

As Willie said, the method from my recent answer to Maklal can be modified and combined with your existing code.

Try this (with changes and comments in bold) but define <<your path>> before starting, noting the comment above that line:

Sub CopyRangeFromSetFolder()

Dim desWS As Worksheet, wb As Workbook, lRow As Long
Dim wbNm As String, Fld As String

Application.ScreenUpdating = False

Set desWS = ThisWorkbook.Sheets("Sheet1")
' define path to set folder, ending in \
Fld = "<<your path>>\"

'get first file with wildcard match
    wbNm = Dir(Fld & "*.xls*", vbNormal)
    ' loop while there's another matching file
    Do While wbNm <> ""
       ' Check it's not this workbook
        If wbNm <> ThisWorkbook.Name Then
            With GetObject(Fld & wbNm)
                With .Sheets("DATA")
                    lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                    .Range("A2:E" & lRow).Copy
                    desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues
                End With
                ' close the file without saving
                .Close False
            End With
        End If

        ' get next matching file
        wbNm = Dir()
    Loop

Application.ScreenUpdating = True
End Sub

You'll see it actually opens then closes each file- you don't have to open them first.

Hope this makes sense and works for you.

Hello Halk,

Yes, I did understand what you wanted to achieve - copy data without needing the file(s) to be open. I haved tweaked John_Ru's code that he provided for Malkal to work with your situation. It requires the user to select the folder to search. The files in the folder are only "opened in the vba code - not needing files to be fully opened as your method does. You will need to adjust some range references to suit your case.

Sub LoopFolder_2()

Dim LRow As Long
Dim OUTrng As Range
Dim wbNm As String

' get last row number in column B  --  adjust to column number per your situation
LRow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.count, 2).End(xlUp).Row

'get user to pick a folder
With Application.FileDialog(msoFileDialogFolderPicker)
   ' If okay was pressed
   If .Show = -1 Then
    'get first file with wildcard match
    wbNm = Dir(.SelectedItems(1) & "\*.xls*", vbNormal)
    ' loop while there's another matching file
    Do While wbNm <> ""
        With GetObject(.SelectedItems(1) & "\" & wbNm)

            'Set OUTrng = .Sheets(5).Range("g2:i1000")
            Set OUTrng = .Sheets(1).Range("A2:B3")   ' this range was used just for testing purpose
            With OUTrng
                Set OUTrng = OUTrng.Resize(.Rows.count, .Columns.count + 1)
            End With
            Application.DisplayAlerts = False
            With OUTrng
                .Resize(.Rows.count, .Columns.count - 1).SpecialCells(xlCellTypeVisible).Copy
            End With
            ' close file ( in vba code ) without saving
            .Close 0
             Application.DisplayAlerts = True
            ' paste to bottom of row B but don't use helper column  --  adjust to column number per your situation
            ThisWorkbook.Sheets("Sheet1").Cells(LRow + 1, 2).PasteSpecial
        End With

        ' update last row number after data has been pasted -- change 3 to a column number without blanks
        With ThisWorkbook.Sheets("Sheet1")
            LRow = Range("A:M").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row '  --  adjust Range per your situation
        End With

        ' get next matching file
        wbNm = Dir()
    Loop
   End If
End With

End Sub
'

Hopefully this is what you were looking for. Testing file is attached.

Thanks to John for doing the hard work.   ;-)

Cheers