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

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.
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

H
  • Question Question
Permision Denied-VBA Code to list sub-folders
Replies
4
Views
122
howard
H
H
  • Question Question
Macro to List Folders excluding Data Stamp within E:\Cobian
Replies
0
Views
73
howard
H
R
  • Question Question
VBA copying files from multiple subfolders according to a list
Replies
1
Views
133
John_w
J
mmn1000
  • Question Question
List folders and files
Replies
1
Views
846
Fuji
F
KlausW
  • Solved
Rename files from old name in column C and new name in column D
Replies
4
Views
195
Domenic
D

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,021
Latest member
Justyna P

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