VBA coding Help - opening and copying several spreadsheets in a folder

[LPS ESQ]

Hello there.

I am a bit rusty with Excel and VBA following differing jobs not needing it so much, however I am now currently in a role where using advanced Excel and VBA would be extremely beneficial. I am currently stuck on something which I am guessing is reasonably simple, and google is not my friend today, so wondering if anyone could please help.

Scenario : I want a spreadsheet (Master.xlsm) and within the spreadsheet there will be a "data tab" and a macro that when runwill open all the other workbooks within the folder, preferably one at a time and copy the data in specified columns of indeterminate length and paste into the master spreadsheet, appending the next lot of copied data to the first blank line in the data tab of Master.xlsm

(All the other spreadsheets are an identical format with same names, formats and everything - just the number of rows differ.)

Problem : I am about 90% of the way there and am completely stumped. The code below opens the first spreadsheet and copies from where to be copied from and pastes fine. However the loop doesn't then move to the next spreadsheet but copies the same spreadsheet...again, again and again...

Things already tried: If I try it with both the 'Green lines in I get a loop without a do error. If I leave the first green line in it throws a bit of a wobbly...

Application.ScreenUpdating = False
    Dim wbDest As Workbook
    Dim wbSource As Workbook
    Set wbDest = ThisWorkbook
    Dim LastRow As Long
    Const strPath As String = "G:\resources\finance\BI Analyst\SSheets for Ruth\"
    ChDir strPath
    StrExtension = "*.xls*"
    
Do While StrExtension <> ""
        
        Set wbSource = Workbooks.Open(strPath & StrExtension)
        With wbSource
            LastRow = .Sheets("Data").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Sheets("data").Range("C4:H" & LastRow).Copy
            wbDest.Sheets("Data").Cells(Rows.Count, "C").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
            .Close savechanges:=False
                 
        End With
        
        [COLOR=rgb(97, 189, 109)]'StrExtension = Dir[/COLOR]
        [COLOR=rgb(97, 189, 109)]'Do While StrExtension <> ""[/COLOR]
    
    Loop

End Sub

Any help would be very gratefully received as I am completely stumped on this and am well aware that I am being a total plonker.

Many thanks

 

[Fluff]

Hi & welcome to MrExcel
I'm surprised that code works at all, try

    StrExtension = Dir(strPath & "*.xls*")
    
Do While StrExtension <> ""
        
        Set wbSource = Workbooks.Open(strPath & StrExtension)
        With wbSource
            LastRow = .Sheets("Data").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            .Sheets("data").Range("C4:H" & LastRow).Copy
            wbDest.Sheets("Data").Cells(Rows.count, "C").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
            .Close savechanges:=False
                 
        End With
        
       StrExtension = Dir
    
    Loop

 

[LPS ESQ]

Fluff - Many thanks for a speedy reply. It works fine.

Told you I was rusty!!

 

[Fluff]

You're welcome & thanks for the feedback.