How to Turning one operation into a Loop in VBA

How to turn one operation into a loop in VBA

Requirement:

The user has created 2 excel spreadsheets attached (see forum link below), one called "HLSR" and another called "Weekly Report".

The user has managed to get the code working so that when you hit "Import Weekly Reports" on the HLSR spreadsheet, it prompts the user to select the file location containing the weekly reports. It then takes the data from cells A5 to H5 on the Weekly Report and copies and pastes the data on the next available row on the HLSR spreadsheet.

The user has multiple weekly reports stored in one folder on the drive. What the user would like the code to do now is perform the same operation mentioned above for each weekly report in that folder (a Loop) - i.e. open each weekly report one by one in the background, take the data from cells A5 to H5 and copy into the next available row on the HLSR.

Below is the code currently being used:

Sub CopySheet()
Application.ScreenUpdating = False
Dim flder As FileDialog
Dim FileName As String
Dim FileChosen As Integer
Dim wkbSource As Workbook
Dim wkbDest As Workbook
Set wkbDest = ThisWorkbook
OpenFile:
Set flder = Application.FileDialog(msoFileDialogFilePicker)
flder.Title = "Weekly Report file location"
flder.InitialFileName = "c:"
flder.InitialView = msoFileDialogViewSmallIcons
flder.Filters.Clear
flder.Filters.Add "Excel Files", "*.xls*"
MsgBox ("Select a folder and then a file to open.")
FileChosen = flder.Show
FileName = flder.SelectedItems(1)
Set wkbSource = Workbooks.Open(FileName)
wkbSource.Sheets("Sheet1").Range("A5:H5").Copy
wkbDest.Sheets("Master").Cells(wkbDest.Sheets("Master").Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
wkbSource.Close savechanges:=False
If MsgBox("Do you want to open another workbook?", vbYesNo) = vbYes Then GoTo OpenFile
End Sub

Sub RAGStatus()
Dim CurCell As Object
For Each CurCell In ActiveWorkbook.ActiveSheet.Range("A1:AZ500")
If CurCell.Value = "Green" Then CurCell.Interior.Color = RGB(0, 204, 0)
If CurCell.Value = "Amber" Then CurCell.Interior.Color = RGB(100, 74.9, 0)
If CurCell.Value = "Red" Then CurCell.Interior.Color = RGB(255, 0, 0)
Next
End Sub

https://www.ozgrid.com/forum/forum/help-forums/excel-vba-macros/1214161-turning-one-operation-into-a-loop-in-vba

Solution:

Code:

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wkbSource As Workbook, desWS As Worksheet
    Set desWS = ThisWorkbook.Sheets("Master")
    Const strPath As String = "C:\Test\" 'change folder path to suit your needs
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            .Sheets("Sheet1").Range("A5:H5").Copy
            desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Obtained from the OzGrid Help Forum.

Solution provided by Mumps.