Excel VBA: select one row down in a loop

Question

I have a source folder that contains many xls files. I want to create a master file - collect all information into one database from all files in the given source.

The following code creates 2 columns in master file and enters 2 values from the given source file (one file):

Sub getData()

Dim XL As Excel.Application

Dim WBK As Excel.Workbook
Dim scrFile As String
Dim myPath As String

myPath = ThisWorkbook.path & "\db\" 'The source folder
scrFile = myPath & "1.xlsx"  'Select first file
 ' Sheet name in the master file is "Sh"
ThisWorkbook.Sheets("Sh").Range("A1").Value = "Column 1"
ThisWorkbook.Sheets("Sh").Range("B1").Value = "Column 2"

Set XL = CreateObject("Excel.Application")
Set WBK = XL.Workbooks.Open(scrFile)

ThisWorkbook.Sheets("Sh").Range("A2").Value = WBK.ActiveSheet.Range("A10").Value
ThisWorkbook.Sheets("Sh").Range("B2").Value = WBK.ActiveSheet.Range("C5").Value

WBK.Close False
Set XL = Nothing

Application.ScreenUpdating = True

End Sub

Now I want to loop through all files and save the values from cells "A10" and "C5" from each file in one database, so the loop should select the next row to save new values.

I have an idea how to loop through all files, but don't know how to switch to the next row:

scrFile = Dir(myPath & "*.xlsx")
Do While scrFile <> ""

    Set XL = CreateObject("Excel.Application")
    Set WBK = XL.Workbooks.Open(scrFile)

    ' Here should be the code to save the values of A10 and C5 of the given file 
    'in the loop in next available row of the master file.

    WBK.Close False
    Set XL = Nothing

    scrFile = Dir
  Loop

Any help will be highly appreciated! :)

Answer 1

I actually have a code here that will loop through each file and deposit the code into your main file. You are also able to choose the directory of the target folder.

Sub GatherData()
Dim sFolder As String

    Application.ScreenUpdating = True

    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Please select a folder..."
        .Show
        If .SelectedItems.Count > 0 Then
            sFolder = .SelectedItems(1) & "\"
        Else
            Exit Sub
        End If
    End With

    Call Consolidate(sFolder, ThisWorkbook)
End Sub

Private Sub Consolidate(sFolder As String, wbMaster As Workbook)
    Dim wbTarget As Workbook
Dim objFso As Object
    Dim objFiles As Object
    Dim objSubFolder As Object
    Dim objSubFolders As Object
    Dim objFile As Object
    Dim ary(3) As Variant
    Dim lRow As Long

    'Set Error Handling
    On Error GoTo EarlyExit

    'Create objects to enumerate files and folders
    Set objFso = CreateObject("Scripting.FileSystemObject")
    Set objFiles = objFso.GetFolder(strFolder).Files
    Set objSubFolders = objFso.GetFolder(strFolder).subFolders

    'Loop through each file in the folder
    For Each objFile In objFiles
        If InStr(1, objFile.Path, ".xls") > 0 Then
            Set wbTarget = Workbooks.Open(objFile.Path)
            With wbTarget.Worksheets(1)
                ary(0) = .Range("B8") 'here you can change the cells you need the data from
                ary(1) = .Range("B12")
                ary(2) = .Range("B14")
            End With

            With wbMaster.Worksheets(1)
                lRow = .Range("E" & .Rows.Count).End(xlUp).Offset(1, 0).Row 'here you can change the row the data is deposited in
                .Range("E" & lRow & ":G" & lRow) = ary
            End With

            wbTarget.Close savechanges:=False
        End If
    Next objFile

    'Request count of files in subfolders
    For Each objSubFolder In objSubFolders
        Consolidate objSubFolder.Path, wbMaster
    Next objSubFolder

EarlyExit:
    'Clean up
    On Error Resume Next
    Set objFile = Nothing
    Set objFiles = Nothing
    Set objFso = Nothing
    On Error GoTo 0
End Sub

Answer 2

You need to recalculate last row in the loop wtih End() function.

Like this for range .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0)

Or to have an integer .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row

---

Give this a try :

Sub getData()
Application.ScreenUpdating = False

Dim XL As Excel.Application, _
    WBK As Excel.Workbook, _
    MS As Worksheet, _
    scrFile As String, _
    myPath As String

'Sheet name in the master file is "Sh"
Set MS = ThisWorkbook.Sheets("Sh")
'The source folder
myPath = ThisWorkbook.Path & "\db\"
MS.Range("A1").Value = "Column 1"
MS.Range("B1").Value = "Column 2"

Set XL = CreateObject("Excel.Application")

scrFile = Dir(myPath & "*.xlsx")
Do While scrFile <> ""

    Set WBK = XL.Workbooks.Open(scrFile)

    ' Here should be the code to save the values of A10 and C5 of the given file
    'in the loop in next available row of the master file.
    With MS
        .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Value = WBK.ActiveSheet.Range("A10").Value
        .Range("B" & .Rows.Count).End(xlUp).Offset(1, 0).Value = WBK.ActiveSheet.Range("C5").Value
    End With

    WBK.Close False
    scrFile = Dir
Loop
XL.Quit
Set XL = Nothing
Set MS = Nothing
Set WBK = Nothing
Application.ScreenUpdating = True

End Sub

Answer 3

For simplicity, just use a counter:

scrFile = Dir(myPath & "*.xlsx")
n = 1  ' skip the first row with headers
Do While scrFile <> ""
    n = n + 1
    Set XL = CreateObject("Excel.Application")
    Set WBK = XL.Workbooks.Open(scrFile)

    ' save the values of A10 and C5 of the given file in the next row
    ThisWorkbook.Sheets("Sh").Range("A" & n).Value = WBK.ActiveSheet.Range("A10").Value
    ThisWorkbook.Sheets("Sh").Range("B" & n).Value = WBK.ActiveSheet.Range("C5").Value

    WBK.Close False
    Set XL = Nothing

    scrFile = Dir
Loop
msgbox n & " files imported."

BTW, you don't need to start a second Excel instance (CreateObject("Excel.Application")) just to open a second workbook. This will slow down your code a lot. Just open, read and close it. Address your master workbook not by ThisWorkbook but assign a varible to it:

Dim masterWB As Excel.Workbook
set masterWB = ThisWorkbook
...
masterWB.Sheets("Sh").Range("A" & n).Value = WBK.ActiveSheet.Range("A10").Value