Move to next empty row when copying from next subfolder

O

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

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
Sort by date Sort by votes
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
rollis13 said:
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
Click to expand...
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
Fluff said:
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
Click to expand...
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
You must log in or register to reply here.

Similar threads

mmn1000
  • Question Question
List folders and files
Replies
1
Views
777
Fuji
F
S
  • Question Question
Adding a new field to the results of my "list the folders inside a specific folder" code
Replies
2
Views
295
John_w
J
C
  • Question Question
Need to add to my search worksheet
Replies
1
Views
104
craigwojo
C
G
  • Question Question
Print all PDFs using VBA
Replies
2
Views
327
spasmex97
S
N
  • Question Question
Infinite loop slideshow
Replies
1
Views
200
Domenic
D

Forum statistics

Threads
1,223,898
Messages
6,175,274
Members
452,628
Latest member
dd2

Share this page

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