Macro that loops through all monthly folders

Djani

Board Regular
Joined
Aug 26, 2015
Messages
61
Dear all,

I am in need of your advice/expertise as I'm currently stuck on programming a macro in Access due to lack of knowledge.
Hereunder I'm giving you some background information which gives you an idea of the requirements for the macro:

Background information
- There are 12 monthly folders as we are working on a fiscal year basis
- Each monthly folder contains another 9 RBU (Regional Business Unit) folders
- Each RBU is split up in multiple country folders -> e.g. CENTER would be Austria/Germany/Switzerland, IBERIA would be Spain, Portugal
- The file names - in the country folders - are always named with the following structure: [VIVA][PRODUCT][COUNTRY][VF] -> e.g. VIVA_LEAF_EGB_VF
- The path file to these files will be something like this -> I:\R&E Internal\01 Reporting & Tools\06 Transaction Price\Transaction price report G5\14 - MOSY FY17\06_September\CEN\GER\Published

What do I want?
The idea is to set up 9 RBU Access databases that contains a macro which automatically loops through each of these monthly folders to consolidate all the data. Each time I run the macro it should restart the entire looping process where it deletes the existing information in Access and re-consolidates the data. I'm completely aware of it not being the most efficient way, but the aim is to provide accurate data as historical information could change due to whatever reason.

Is this even feasible?
If you need additional information, please let me know so I can provide you this

Many thanks for your time & willingness to help me out

Have a nice day

PS: I wanted to upload a local picture, but I don't see the URL

Djani
 

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
The idea should be, load in all data (excel?)
v1. then STOP using excel data and input data in access.
or
v2. Stop importing ALL historical data (once loaded) then continue to load ONLY new sheets that come in.

not
load all historical data over and over, etc.
 
Upvote 0
the code below will cycle thru all folders and import excel sheets, assuming they are all designed alike and all import to the same table.
modify as needed:

usage:
ImportAllFoldersAndSubFolders "c:\folder\folder2"

Code:
Public Sub ImportAllFoldersAndSubFolders(ByVal pvDir)
    Dim fso, oFolder, oSubfolder, oFile, queue As Collection
    Dim vFile
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set queue = New Collection
    queue.Add fso.GetFolder(pvDir) 'obviously replace


    Do While queue.Count > 0
        Set oFolder = queue(1)
        queue.Remove 1
        
            For Each oFile In oFolder.Files
                              '...insert any file processing code here...
                If InStr(oFile.Name, ".xls") > 0 Then
                   Debug.Print oFile.Name, oFolder
                   vFile = oFolder & "\" & oFile.Name
                   DoCmd.TransferSpreadsheet acImport, "tTable1", vFile, True
                End If
            Next oFile
        
        For Each oSubfolder In oFolder.SubFolders
            queue.Add oSubfolder
            Debug.Print oSubfolder
        Next oSubfolder
    Loop
    
Set fso = Nothing
Set oFolder = Nothing
Set oSubfolder = Nothing
Set oFile = Nothing
Set queue = Nothing
End Sub
 
Last edited:
Upvote 0
@ranman256, many thanks for your input

I was digging a little deeper and in the end I was able to assemble a macro which automatically loops through one folder and copy-pastes the data into the open workbook:

Code:
Sub LoopThroughFolder()
    Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
    Dim Rws As Long, Rng As Range
    Set Wb = ThisWorkbook
    'change the address to suite
    MyDir = "H:\My Documents\Djani\MPCR\Project\FY17\CEN\GER\Qashqai\"
    MyFile = Dir(MyDir & "*.xlsb")    'change file extension
    ChDir MyDir
    Application.ScreenUpdating = 0
    Application.DisplayAlerts = 0
    Do While MyFile <> ""
        Workbooks.Open (MyFile)
        With Worksheets("Monthly_DB")
            Rws = .Cells(Rows.Count, "A").End(xlUp).Row
            Set Rng = Range(.Cells(2, 64), .Cells(Rws, 2))
            Rng.Copy Wb.Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            ActiveWorkbook.Close False
        End With
        MyFile = Dir()
    Loop
End Sub

However, as this macro is purely designed to loop through one folder, what should I modify within this macro in order for it to loop through multiple subfolders?
I want it to do the exact same thing by copy-pasting the data in the files that are located within the subfolders.

Hopefully you can help me with this!
 
Upvote 0
Hey guys,

Sorry to bump the thread, but can anybody help me out on this?

In the meantime I dug a little deeper and found a macro that finds and lists all files in a directory and its subdirectories (http://software-solutions-online.co...-files-in-a-directory-and-its-subdirectories/)

Code:
Option Explicit
'the first row with data
Const ROW_FIRST As Integer = 5
'This is an event handler. It executes when the user presses the run button
Private Sub btnGet_Click()
'determines if the user selects a directory from the folder dialog
Dim intResult As Integer
'the path selected by the user from the folder dialog
Dim strPath As String
'Filesystem object
Dim objFSO As Object
'the current number of rows
Dim intCountRows As Integer
Application.FileDialog(msoFileDialogFolderPicker).Title = _
"Select a Path"
'the dialog is displayed to the user
intResult = Application.FileDialog( _
msoFileDialogFolderPicker).Show
'checks if user has cancled the dialog
If intResult <> 0 Then
 strPath = Application.FileDialog(msoFileDialogFolderPicker _
 ).SelectedItems(1)
'Create an instance of the FileSystemObject
 Set objFSO = CreateObject("Scripting.FileSystemObject")
'loops through each file in the directory and prints their names and path
 intCountRows = GetAllFiles(strPath, ROW_FIRST, objFSO)
'loops through all the files and folder in the input path
 Call GetAllFolders(strPath, objFSO, intCountRows)
End If
End Sub
'''
'This function prints the name and path of all the files in the directory strPath
'strPath: The path to get the list of files from
'intRow: The current row to start printing the file names
'objFSO: A Scripting.FileSystem object.
Private Function GetAllFiles(ByVal strPath As String, _
ByVal intRow As Integer, ByRef objFSO As Object) As Integer
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
i = intRow - ROW_FIRST + 1
Set objFolder = objFSO.GetFolder(strPath)
For Each objFile In objFolder.Files
 'print file name
 Cells(i + ROW_FIRST - 1, 1) = objFile.Name
'print file path
 Cells(i + ROW_FIRST - 1, 2) = objFile.Path
 i = i + 1
Next objFile
GetAllFiles = i + ROW_FIRST - 1
End Function
'''
'This function loops through all the folders in the
'input path. It makes a call to the GetAllFiles
'function. It also makes a recursive call to itself
'strFolder: The folder to loop through
'objFSO: A Scripting.FileSystem object
'intRow: The current row to print the file data on
Private Sub GetAllFolders(ByVal strFolder As String, _
ByRef objFSO As Object, ByRef intRow As Integer)
Dim objFolder As Object
Dim objSubFolder As Object
'Get the folder object
Set objFolder = objFSO.GetFolder(strFolder)
'loops through each file in the directory and
'prints their names and path
For Each objSubFolder In objFolder.subfolders
 intRow = GetAllFiles(objSubFolder.Path, _
 intRow, objFSO)
'recursive call to to itsself
 Call GetAllFolders(objSubFolder.Path, _
 objFSO, intRow)
Next objSubFolder
End Sub

Is there any possibility to combine this macro with the one I posted earlier?
The goal is to copy-paste the data from sheet "Monthly_DB" of all files in the folders

Please let me know if you need some additional information!
 
Upvote 0
Hello all,

Sorry for bumping this thread, but is there anyone that could possibly help me out?
I still haven't found a solution in finding a macro that automatically loops through all excel files within a directory

Kind regards

Djani
 
Upvote 0
HI,

Have you considered using Power BI? It seems this would probably be make your task a lot more simple.

Dan.
 
Upvote 0
Hello stumac,

My bad.. thanks a lot for the help anyways
I was able to find a macro - created by Ron de Bruin - but I want to customize it a little to my own needs.

Code:
Sub MergeAllWorkbooks()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String
    Dim SourceRcount As Long, FNum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long
    Dim FirstCell As String


    ' Change this to the path\folder location of your files.
    MyPath = "H:\My Documents\Djani\MPCR\Project\FY17\CEN\GER\Qashqai"


    ' Add a slash at the end of the path if needed.
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If


    ' If there are no Excel files in the folder, exit.
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If


    ' Fill the myFiles array with the list of Excel files
    ' in the search folder.
    FNum = 0
    Do While FilesInPath <> ""
        FNum = FNum + 1
        ReDim Preserve MyFiles(1 To FNum)
        MyFiles(FNum) = FilesInPath
        FilesInPath = Dir()
    Loop


    ' Set various application properties.
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With


    ' Add a new workbook with one sheet.
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    rnum = 1


    ' Loop through all files in the myFiles array.
    If FNum > 0 Then
        For FNum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
            On Error GoTo 0


            If Not mybook Is Nothing Then
                On Error Resume Next


                ' Change this range to fit your own needs.
                With mybook.Worksheets("7 - Monthly_DB")
                   FirstCell = "A2"
                   Set sourceRange = .Range(FirstCell & ":" & RDB_Last(3, .Cells))
                   ' Test if the row of the last cell is equal to or greater than the row of the first cell.
                   If RDB_Last(1, .Cells) < .Range(FirstCell).Row Then
                      Set sourceRange = Nothing
                   End If
                End With


                If Err.Number > 0 Then
                    Err.Clear
                    Set sourceRange = Nothing
                Else
                    ' If source range uses all columns then
                    ' skip this file.
                    If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                        Set sourceRange = Nothing
                    End If
                End If
                On Error GoTo 0


                If Not sourceRange Is Nothing Then


                    SourceRcount = sourceRange.Rows.Count


                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                        MsgBox "There are not enough rows in the target worksheet."
                        BaseWks.Columns.AutoFit
                        mybook.Close savechanges:=False
                        GoTo ExitTheSub
                    Else


                        ' Set the destination range.
                        Set destrange = BaseWks.Range("A" & rnum)


                        ' Copy the values from the source range
                        ' to the destination range.
                        With sourceRange
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        End With
                        destrange.Value = sourceRange.Value


                        rnum = rnum + SourceRcount
                    End If
                End If
                mybook.Close savechanges:=False
            End If


        Next FNum
        BaseWks.Columns.AutoFit
    End If


ExitTheSub:
    ' Restore the application properties.
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub

When I run this macro it automatically opens a new workbook and merges all data in there, but I'd like to have the data merged in the current/open workbook.

I understand I have to change the "BaseWks" variable etc. but I'm not entirely sure how to adapt the rest of the macro.
Is this something you can help me with?

Many thanks

Djani
 
Last edited:
Upvote 0
HI,

Have you considered using Power BI? It seems this would probably be make your task a lot more simple.

Dan.

For sure, but I'm not yet at that stage. Streamlining all data is currently the main task I'm focused on, and this is going to take some time as I literally had to start from ground-zero. The company I'm working for is somewhat 90% Excel based.
 
Upvote 0

Forum statistics

Threads
1,213,485
Messages
6,113,931
Members
448,533
Latest member
thietbibeboiwasaco

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