Import named sheet from multiple excel files into a single sheet in defined excel file

I need to copy a specific sheet from every excel file within a folder to an existing template excel file, into a single sheet with no spaces between the data. I want it to run as a loop; preferably behind the scenes, I don't mind if the files are opening.

Copy Range A3:0 to LastCell from worksheet “JV Upload”, from every “*.xls” file within folder path “P:\BK\May 16 - Apr 17\3. July”.

Paste the copied data as Values into an existing workbook (which I would be running my Macro out of), Filename:="P:\BK \May 16 - Apr 17\BS.xlsm" onto an existing worksheet named "BS", starting in cell A3.

p.s. this is my first post.

Re: "starting in cell A3."
I assume that you have data (Headers?) in Cells A1 and A2. Right?

That is correct. A1:O2 have headers, the headers are the same on all sheets including the one I am trying to merge all of the other sheets into.

Any particular part of Europe you love?
Try this
Check all references, Sheets, Ranges etc and change where required.
Also, to be safe, try it on a copy of your workbook first.

Sub Copy_Into_This_Book()
    Const fPath As String = "P:\BK\May 16 - Apr 17\3. July\"
    Dim sName As String
    Dim lr As Long
    
    With Application
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    sName = Dir(fPath & "*.xls*")    '<---- xls files only! Change to *.xls* if all type excel files
    Do Until sName = ""
        With GetObject(fPath & sName)
            With .Sheets("JV Upload")
                lr = .Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row
                .Range("A3:O" & lr).Copy ThisWorkbook.Sheets("BS").Cells(Rows.Count, 1).End(xlUp).Offset(1)
            End With
            .Close True
        End With

        sName = Dir
    Loop
    With Application
        .Calculation = xlAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

Thank-you! I am not having much luck right now, but it could be because I am trying to log into my work computer remotely to do it. I may have to wait until I am back in the office on Monday to try again.

It didn't do anything when I tried it. I did make a backup of my files though to be safe before attempting to run it.

It worked when I tried with 12 workbooks in a folder.
What I did is make a temp folder, copied a bunch of workbooks into it, obviously changed the path in the code and ran the code.
You have to make sure that your path is actually "P" and whatever.

Hello, back at work and trying this again.

The Do Until Loop seems to be not working as sName is not storing a value. It is blank going into the loop, so the loop is skipped when running.

The 2nd line in the code gives the path. You must have this wrong. An extra space, a missing space or whatever. It has to be exact.
Copy and paste it and see what happens.

I was missing the last \ on the file path...

So, now it is working the only thing I still need is for it to paste the data as values instead of linking back to the original file.

I don't know what the best way would be but try this just before your "End Sub" line

With Sheets("Sheet1").UsedRange    '<----- here the sheet name you copied into
    .Value = .Value
End With

It is giving me Run-time error '9':Subscript out of range

I do not know anything about links but from what I read it can be a pain.
But this should, if my thinking is right, only copy the values across.
See if it works for you.

Replace this

With .Sheets("JV Upload")
    lr = .Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row
    .Range("A3:O" & lr).Copy ThisWorkbook.Sheets("BS").Cells(Rows.Count, 1).End(xlUp).Offset(1)
End With

with this

With .Sheets("JV Upload")
    lr = .Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row
    ThisWorkbook.Sheets("BS").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(lr - 2, 18).Value = .Range("C3:T" & lr).Value
End With

Thank you, thank you, thank you! This worked like a charm

Here is the code you gave me but all together with the modifications you sent:

Sub Copy_Into_This_Book()
    Const fPath As String = "P:\BK\May 16 - Apr 17\July\" <---- exact file path with \ at the end
    Dim sName As String
    Dim lr As Long
    
    With Application
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    sName = Dir(fPath & "*.xls*")    '<---- xls files only! Change to *.xls* if all type excel files
    Do Until sName = ""
        With GetObject(fPath & sName)
        With .Sheets("JV Upload") 
         lr = .Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row
         ThisWorkbook.Sheets("BS").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(lr - 2, 18).Value = .Range("A3:O" & lr).Value  
         End With
            .Close True
        End With

        sName = Dir
    Loop
    With Application
        .Calculation = xlAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

I am glad that it works for you.
Good luck