Move to next empty row when copying from next subfolder

Orfevre

New Member
Joined
Jul 11, 2022
Messages
25
Office Version
  1. 365
Platform
  1. Windows
Hello, I have the below code that is copying specific cells from excel files in a directory of subfolders, however each time it moves to a new subfolder, it copies over the data from the files in the previous subfolders. How would I get the code to always find the next empty row in the destination sheet "report" and continually do that until all files have been cycled through in all subfolders.

VBA Code:
Sub Copdata()
    Call GetFiles("D:\data\Rev\Analysis\records\files\")
End Sub
Sub GetFiles(ByVal path As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")

Dim folder As Object
Set folder = fso.GetFolder(path)

Dim subfolder As Object
Dim file As Object

For Each subfolder In folder.SubFolders
    GetFiles (subfolder.path)
Next subfolder

Set destSheet = ActiveWorkbook.Worksheets("Report")
r = 0

For Each file In folder.Files
    Set fromWorkbook = Workbooks.Open(file)
    With fromWorkbook.Worksheets("Dashboard")
        destSheet.Range("A2").Offset(r).Value = .Range("C5").Value
        destSheet.Range("B2").Offset(r).Value = .Range("C3").Value
        r = r + 1
    End With
    fromWorkbook.Close savechanges:=False
Next file

Set fso = Nothing
Set folder = Nothing
Set subfolder = Nothing
Set file = Nothing


End Sub
 

Excel Facts

What is the shortcut key for Format Selection?
Ctrl+1 (the number one) will open the Format dialog for whatever is selected.
Have a try with these few changes.
It's always recommended to declare variables; also I added no flickering.
VBA Code:
Option Explicit
Dim r          As Long                            '<- added
Sub Copdata()
    r = 0                                         '<- moved up
    Application.ScreenUpdating = False            '<- added
    Call GetFiles("D:\data\Rev\Analysis\records\files\")
    Application.ScreenUpdating = True             '<- added
    MsgBox "Done!"
End Sub

Sub GetFiles(ByVal path As String)
    Dim fso    As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim folder As Object
    Set folder = fso.GetFolder(path)
    Dim subfolder As Object
    Dim file   As Object
    Dim destSheet As Variant, fromWorkbook As Variant '<- added
    Set destSheet = ActiveWorkbook.Worksheets("Report") '<- moved up
    For Each subfolder In folder.SubFolders
        GetFiles (subfolder.path)
    Next subfolder
    For Each file In folder.Files
        Set fromWorkbook = Workbooks.Open(file)
        With fromWorkbook.Worksheets("Dashboard")
            destSheet.Range("A2").Offset(r).Value = .Range("C5").Value
            destSheet.Range("B2").Offset(r).Value = .Range("C3").Value
            r = r + 1
        End With
        fromWorkbook.Close SaveChanges:=False
    Next file
    Set fso = Nothing
    Set folder = Nothing
    Set subfolder = Nothing
    Set file = Nothing
End Sub
 
Last edited:
Upvote 0
How about
VBA Code:
Sub Copdata()
    Dim r As Long
    Call GetFiles("D:\data\Rev\Analysis\records\files\", r)
End Sub
Sub GetFiles(ByVal path As String, r As Long)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")

Dim folder As Object
Set folder = fso.GetFolder(path)

Dim subfolder As Object
Dim file As Object

For Each subfolder In folder.SubFolders
    GetFiles subfolder.path, r
Next subfolder

Set destSheet = ActiveWorkbook.Worksheets("Report")

For Each file In folder.Files
    Set fromWorkbook = Workbooks.Open(file)
    With fromWorkbook.Worksheets("Dashboard")
        destSheet.Range("A2").Offset(r).Value = .Range("C5").Value
        destSheet.Range("B2").Offset(r).Value = .Range("C3").Value
        r = r + 1
    End With
    fromWorkbook.Close savechanges:=False
Next file

Set fso = Nothing
Set folder = Nothing
Set subfolder = Nothing
Set file = Nothing


End Sub
 
Upvote 0
Solution
Have a try with these few changes.
It's always recommended to declare variables; also I added no flickering.
VBA Code:
Option Explicit
Dim r          As Long                            '<- added
Sub Copdata()
    r = 0                                         '<- moved up
    Application.ScreenUpdating = False            '<- added
    Call GetFiles("D:\data\Rev\Analysis\records\files\")
    Application.ScreenUpdating = True             '<- added
    MsgBox "Done!"
End Sub

Sub GetFiles(ByVal path As String)
    Dim fso    As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim folder As Object
    Set folder = fso.GetFolder(path)
    Dim subfolder As Object
    Dim file   As Object
    Dim destSheet As Variant, fromWorkbook As Variant '<- added
    Set destSheet = ActiveWorkbook.Worksheets("Report") '<- moved up
    For Each subfolder In folder.SubFolders
        GetFiles (subfolder.path)
    Next subfolder
    For Each file In folder.Files
        Set fromWorkbook = Workbooks.Open(file)
        With fromWorkbook.Worksheets("Dashboard")
            destSheet.Range("A2").Offset(r).Value = .Range("C5").Value
            destSheet.Range("B2").Offset(r).Value = .Range("C3").Value
            r = r + 1
        End With
        fromWorkbook.Close SaveChanges:=False
    Next file
    Set fso = Nothing
    Set folder = Nothing
    Set subfolder = Nothing
    Set file = Nothing
End Sub
Thank you for this, however I'm getting subscript out of range error on this line of code
VBA Code:
Set destSheet = ActiveWorkbook.Worksheets("Report")
 
Upvote 0
How about
VBA Code:
Sub Copdata()
    Dim r As Long
    Call GetFiles("D:\data\Rev\Analysis\records\files\", r)
End Sub
Sub GetFiles(ByVal path As String, r As Long)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")

Dim folder As Object
Set folder = fso.GetFolder(path)

Dim subfolder As Object
Dim file As Object

For Each subfolder In folder.SubFolders
    GetFiles subfolder.path, r
Next subfolder

Set destSheet = ActiveWorkbook.Worksheets("Report")

For Each file In folder.Files
    Set fromWorkbook = Workbooks.Open(file)
    With fromWorkbook.Worksheets("Dashboard")
        destSheet.Range("A2").Offset(r).Value = .Range("C5").Value
        destSheet.Range("B2").Offset(r).Value = .Range("C3").Value
        r = r + 1
    End With
    fromWorkbook.Close savechanges:=False
Next file

Set fso = Nothing
Set folder = Nothing
Set subfolder = Nothing
Set file = Nothing


End Sub
Thanks for helping with my problem, similar to the other suggestion I get a subscript out of range error on
VBA Code:
Set destSheet = ActiveWorkbook.Worksheets("Report")
 
Upvote 0
Where did you hide your master sheet called "Report" ?
 
Upvote 0
No idea what's going on, as you can see you have the same issue with the Fluff's macro.
All you need is a workbook that should have a sheet called Report and the macro in a standard module.
 
Upvote 0
Yep, so got exactly that and similar to you no idea why it wont work.
 
Upvote 0

Forum statistics

Threads
1,214,833
Messages
6,121,865
Members
449,052
Latest member
Fuddy_Duddy

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top