How to turn one operation into a loop in VBA
Category: [Excel] Demo Available
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
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.
See also: Index to Excel VBA Code and Index to Excel Freebies and Lesson 1 - Excel Fundamentals and Index to how to… providing a range of solutions and Index to new resources and reference sheets
See also:
| How to use looping to delete cells of similar value |
| How to use loop IF, if range is unknown |
| How to loop a macro with various length columns |
| How to loop a macro with various length columns |
Click here to visit our Free 24/7 Excel/VBA Help Forum where there are thousands of posts you can get information from, or you can join the Forum and post your own questions.