Compiling data from multiple excel files in multiple subfolders into one worksheet

D

DanSMT

Board Regular
Joined
Sep 13, 2019
Messages
203
Office Version
  1. 2013
Platform
  1. Windows
I hope im on the right track. Im trying to compile data from multiple files in multiple sub folders within a directory. The code appears the hang up when trying to imbed the information into the "pull from ri" sheet. Not sure what im missing here.

VBA Code: 
Sub sample()
    Dim FileSystem As Object
    Dim HostFolder As String

    HostFolder = "H:\ri\"

    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    DoFolder FileSystem.GetFolder(HostFolder)
End Sub

Sub DoFolder(Folder)
    Dim SubFolder
    For Each SubFolder In Folder.SubFolders
        DoFolder SubFolder
    Next
    Dim File
    Dim WSL As String
    Dim LR As Long
    For Each File In Folder.Files
        ' Operate on each file
    Dim emptyRow As Long
    emptyRow = WorksheetFunction.CountA(Range("A:A")) + 1
        If InStr(File, ".xlsx") Then
        Workbooks("pull from ri").Worksheets("Sheet1").Activate
        Workbooks("pull from ri").Worksheets("sheet1").Cells(emptyRow, 1).text = File.Cells("c2").text
        End If
    Next
End Sub
 
Sort by date Sort by votes
Marc L said:
​
First, if many files within many subfolders so using FSO is not such a great idea as it can be slower than VBA Dir function !​
It could be not the case here if you have only Excel files in those folders.​
​
Yes you are right : you must desactivate the screen updating before to loop and re-activate it once done …​
Click to expand...
Thanks! I remember now. I also figured out the line progression issue and it is because I did not call out the full range in the target cells.
 
Upvote 0

Excel Facts

Show numbers in thousands?
Use a custom number format of #,##0,K. Each comma after the final 0 will divide the displayed number by another thousand
Marc,

I've been running this off of my network on a few files and it appears to take about 7 minutes on 200 files. This is going to take roughly 14 hours on 23,000 files. Any idea how to speed this up?

Sorry forgot code....

VBA Code: 
Sub sample()
    Dim FileSystem As Object
    Dim HostFolder As String

    HostFolder = "H:\ri\"

    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    DoFolder FileSystem.GetFolder(HostFolder)
End Sub

Sub DoFolder(Folder)
    Dim SubFolder
    For Each SubFolder In Folder.SubFolders
        DoFolder SubFolder
    Next
    Dim File
    For Each File In Folder.Files
        ' Operate on each file
        Application.ScreenUpdating = False
    With File
        If InStr(File, ".xlsx") Then
        Workbooks.Open (File)
            If InStr(File, "#0257") Then
                With Workbooks.Open(File).ActiveSheet
                    .Range("C2").Copy Workbooks("pull from ri").Sheets("sheet1").Range("A" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("C3").Copy Workbooks("pull from ri").Sheets("sheet1").Range("E" & Rows.Count).End(xlUp)(1)
                    .Range("I2").Copy Workbooks("pull from ri").Sheets("sheet1").Range("F" & Rows.Count).End(xlUp)(1)
                    .Range("I3").Copy Workbooks("pull from ri").Sheets("sheet1").Range("H" & Rows.Count).End(xlUp)(1)
                    .Range("I4").Copy Workbooks("pull from ri").Sheets("sheet1").Range("R" & Rows.Count).End(xlUp)(1)
                    .Range("C6").Copy Workbooks("pull from ri").Sheets("sheet1").Range("K" & Rows.Count).End(xlUp)(1)
                    .Range("C7").Copy Workbooks("pull from ri").Sheets("sheet1").Range("L" & Rows.Count).End(xlUp)(1)
                    .Range("C8").Copy Workbooks("pull from ri").Sheets("sheet1").Range("N" & Rows.Count).End(xlUp)(1)
                    .Range("C9").Copy Workbooks("pull from ri").Sheets("sheet1").Range("M" & Rows.Count).End(xlUp)(1)
                    .Range("I6").Copy Workbooks("pull from ri").Sheets("sheet1").Range("P" & Rows.Count).End(xlUp)(1)
                    .Range("I9").Copy Workbooks("pull from ri").Sheets("sheet1").Range("O" & Rows.Count).End(xlUp)(1)
                End With
            ActiveWorkbook.Close
            ElseIf InStr(File, "#0258") Then
                With Workbooks.Open(File).ActiveSheet
                    .Range("C4").Copy Workbooks("pull from ri").Sheets("sheet1").Range("A" & Rows.Count).End(xlUp)(1 + 1)
                    .Range("C5").Copy Workbooks("pull from ri").Sheets("sheet1").Range("E" & Rows.Count).End(xlUp)(1)
                    .Range("C8").Copy Workbooks("pull from ri").Sheets("sheet1").Range("F" & Rows.Count).End(xlUp)(1)
                    .Range("D12").Copy Workbooks("pull from ri").Sheets("sheet1").Range("J" & Rows.Count).End(xlUp)(1)
                    .Range("D12").Copy Workbooks("pull from ri").Sheets("sheet1").Range("Q" & Rows.Count).End(xlUp)(1)
                    .Range("D13").Copy Workbooks("pull from ri").Sheets("sheet1").Range("R" & Rows.Count).End(xlUp)(1)
                    .Range("D14").Copy Workbooks("pull from ri").Sheets("sheet1").Range("W" & Rows.Count).End(xlUp)(1)
                    .Range("D15").Copy Workbooks("pull from ri").Sheets("sheet1").Range("H" & Rows.Count).End(xlUp)(1)
                    .Range("D16").Copy Workbooks("pull from ri").Sheets("sheet1").Range("S" & Rows.Count).End(xlUp)(1)
                    .Range("D17").Copy Workbooks("pull from ri").Sheets("sheet1").Range("X" & Rows.Count).End(xlUp)(1)
                    .Range("J12").Copy Workbooks("pull from ri").Sheets("sheet1").Range("T" & Rows.Count).End(xlUp)(1)
                    .Range("J13").Copy Workbooks("pull from ri").Sheets("sheet1").Range("Y" & Rows.Count).End(xlUp)(1)
                    .Range("J14").Copy Workbooks("pull from ri").Sheets("sheet1").Range("U" & Rows.Count).End(xlUp)(1)
                    .Range("J15").Copy Workbooks("pull from ri").Sheets("sheet1").Range("Z" & Rows.Count).End(xlUp)(1)
                    '.Range("J16").Copy Workbooks("pull from ri").Sheets("sheet1").Range("" & Rows.Count).End(xlUp)(1)
                    .Range("C19").Copy Workbooks("pull from ri").Sheets("sheet1").Range("EW" & Rows.Count).End(xlUp)(1)
                    .Range("C20").Copy Workbooks("pull from ri").Sheets("sheet1").Range("EX" & Rows.Count).End(xlUp)(1)
                    .Range("I19").Copy Workbooks("pull from ri").Sheets("sheet1").Range("EY" & Rows.Count).End(xlUp)(1)
                    .Range("I20").Copy Workbooks("pull from ri").Sheets("sheet1").Range("EZ" & Rows.Count).End(xlUp)(1)
                    .Range("D23").Copy Workbooks("pull from ri").Sheets("sheet1").Range("AA" & Rows.Count).End(xlUp)(1)
                    .Range("D24").Copy Workbooks("pull from ri").Sheets("sheet1").Range("AB" & Rows.Count).End(xlUp)(1)
                    .Range("D25").Copy Workbooks("pull from ri").Sheets("sheet1").Range("AE" & Rows.Count).End(xlUp)(1)
                    '.Range("D26").Copy Workbooks("pull from ri").Sheets("sheet1").Range("" & Rows.Count).End(xlUp)(1)
                    .Range("D27").Copy Workbooks("pull from ri").Sheets("sheet1").Range("AC" & Rows.Count).End(xlUp)(1)
                    .Range("I22").Copy Workbooks("pull from ri").Sheets("sheet1").Range("AF" & Rows.Count).End(xlUp)(1)
                    .Range("I23").Copy Workbooks("pull from ri").Sheets("sheet1").Range("AG" & Rows.Count).End(xlUp)(1)
                    .Range("I24").Copy Workbooks("pull from ri").Sheets("sheet1").Range("AH" & Rows.Count).End(xlUp)(1)
                    .Range("I25").Copy Workbooks("pull from ri").Sheets("sheet1").Range("AD" & Rows.Count).End(xlUp)(1)
                    '.Range("I26").Copy Workbooks("pull from ri").Sheets("sheet1").Range("" & Rows.Count).End(xlUp)(1)
                    
                End With
            ActiveWorkbook.Close
            End If
        End If
    End With
    Next
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
​
If the cell formatting does not need to be conserved so do not use the Copy method but some DestinationCell.Value = SourceCell.Value …​
​
Another way - but advanced - is to use ADODB …​
​
It's the casual drawback when using Excel as a database software, it can be slow; any database software is at least 50 times faster …​
 
Upvote 0
I must be doing something wrong here, because it is not pulling the data when i change to value


VBA Code: 
    With File
        If InStr(File, ".xlsx") Then
        Workbooks.Open (File)
            If InStr(File, "#0257") Then
                With Workbooks.Open(File).ActiveSheet
                    .Range("C2").Value = Workbooks("pull from ri").Sheets("sheet1").Range("A" & Rows.Count).End(xlUp)(1 + 1).Value
                    .Range("C3").Value = Workbooks("pull from ri").Sheets("sheet1").Range("E" & Rows.Count).End(xlUp)(1).Value
                    .Range("I2").Value = Workbooks("pull from ri").Sheets("sheet1").Range("F" & Rows.Count).End(xlUp)(1).Value
                    .Range("I3").Value = Workbooks("pull from ri").Sheets("sheet1").Range("H" & Rows.Count).End(xlUp)(1).Value
                    .Range("I4").Value = Workbooks("pull from ri").Sheets("sheet1").Range("R" & Rows.Count).End(xlUp)(1).Value
 
Upvote 0

You must reverse the cells as DestinationCell.Value = SourceCell.Value, you have commited the opposite !​
 
Upvote 0
You must log in or register to reply here.

Similar threads

O
  • Question
Converting a code to a UDF.
Replies
1
Views
347
offthelip
O
P
  • Solved
Find Replace cell content in Multiple Workbooks in Multiple subfolders
Replies
3
Views
133
Mike_AL
M
B
  • Solved
VBA macro to copy files from one folder (and all it's subfolders, and their subfolders, and their subfolders with an exception....) to another folder?
Replies
4
Views
804
Bering
B
H
  • Question
Macro to move csv files within-subfolder to folder "Old Templates"
Replies
2
Views
432
howard
H
K
  • Locked
  • Question
VBA Code to move subfolders and all files from source folder to destination folder
Replies
1
Views
1K
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,216,222
Messages
6,129,588
Members
449,520
Latest member
TBFrieds

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