Consolidating Data from Multiple Workbooks in Multiple Folders based on Workbook Name

[AnilPullagura]

Thanks to the Forum!!! <?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
I learnt quite a bit of Excel VBA thru this forum. I have successfully created some macros to make my life easier. Thanks to forum for making this happen.<o></o>
<o></o>
Now I am stuck with another Project which I feel is beyond my caliber, hence seeking help!!!<o></o>
Project Description:<o></o>
There are 15 folders (By individual’s Name) in a Folder named “July – Entire Team”. <o></o>
Each of the 15 folders has 12 Excel workbooks which are identical. To be more specific, these 12 Workbooks denote 12 processes.<o></o>
I have another consolidation Folder name “July – Consolidated” and in this folder I have the same 12 workbooks having similar naming conventions.<o></o>
The requirement is that, <o></o>
· The macro should Open a workbook(for eg : 2117 – Exists) from “July – Consolidated” Folder<o></o>
· Then it should Open workbook with same name from each of the 15folders within “July – Entire Team” Folder,<o></o>
· Copy the data to the workbook from “July – Consolidated”<o></o>
I hope I am able to explain this a little bit. I started with a code and was stuck in between.<o></o>
Could any one of you please spare your time to look into this… Any help is greatly appreciated<o></o>

Public objFSO       As Object
    Public objFolder    As Object
    Public FileName     As Object
    Public i            As Long
    Public wkshtnames
    Public k()
Sub SubFoldersFiles(Folder)
Dim objfilename As String
objfilename = wkshtnames
    For Each SubFolder In Folder.SubFolders
        Set objFolder = objFSO.GetFolder(SubFolder.Path)
        For Each FileName In objFolder.Files
            If Not FileName.Name Like objfilename & "*" Then
                i = i + 1
                ReDim Preserve k(1 To i)
                k(i) = objFolder & "\" & FileName.Name
            End If
        Next
        SubFoldersFiles SubFolder
    Next
End Sub
 
Sub ListFiles()
 
Application.ScreenUpdating = False
Application.DisplayAlerts = False
 
    Dim StartFolder
    Dim wb          As Workbook, wbcur As Workbook
    Dim pName       As String
    Dim shName      As String
    Dim arrOutput()
    Dim opCols() As Long
    Dim ColHeads
    Dim j As Long, n As Long, c As Long, m As Long, l As Long
    Dim wksht As Worksheet
    Dim wkshtnames()
 
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        StartFolder = "C:\Users\Apullagura\Desktop\July - Team Enrollment"  'InputBox("Please enter the Folder path", "Folder Locator")
    If StartFolder = "" Then Exit Sub
 
    Set objFolder = objFSO.GetFolder(StartFolder)
        SubFoldersFiles objFSO.GetFolder(StartFolder)
    Set wbcur = Workbooks("Enrollment Consolidation Report.xls")
 
'ASSIGN WKSHTS NAMES TO ARRAY
        m = 0
    For Each wksht In ActiveWorkbook.Worksheets
        m = m + 1
        ReDim Preserve wkshtnames(1 To m)
        wkshtnames(m) = wksht.Name
    Next wksht
 
    For m = LBound(wkshtnames) To UBound(wkshtnames)
        'MsgBox wkshtnames(m)
 
        ReDim arrOutput(1 To 1000, 1 To 10)
    ColHeads = Array(Worksheets(wkshtnames(m)).Range("A1" & Range("A1").End(xlToRight).Address))
 
 
    With wbcur.Worksheets(m) '<<==adjust to suit
        On Error Resume Next
        For j = 0 To UBound(ColHeads)
            opCols(j + 1) = Cells.Find(What:=CStr(ColHeads(j)), LookAt:=xlPart).Column
        Next
    End With
 
    For i = 1 To UBound(k)
 
        Set wb = Workbooks.Open(k(i), 0)
 
        n = n + 1
 
        'DATA TRANSFERRED TO VARIABLES
        With wb.Worksheets("Sheet1")
        End With
 
        wb.Close
 
    Next
 
 
    On Error GoTo 0
    If n Then
        With wbcur.Worksheets(1)
            .Range("a2").Resize(n, 10).Value = arrOutput
        End With
    End If
 
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
 
   Next m
 
End Sub

 

[AnilPullagura]

Bump!!!

 

[AnilPullagura]

One more BUMP!!!

 

[AnilPullagura]

One more BUMP!!! sorry for bumping, but am in dire necessity of a solution.

Its been 72 hrs since I am struggling with this.

 

[AnilPullagura]

Trying ma luck for today!!!! BUMP!!!!!!!!

 

[SydneyGeek]

See how you go with this. You will need to set a reference to the Microsoft Scripting Runtime.

Sub HarvestWorkbooks()
    Dim dirHome As String
    Dim dirAway As String
    Dim File As String
    Dim objFldr As Folder
    Dim objSubFldr As Folder
    Dim objFSO As Scripting.FileSystemObject
    Dim wbkSource As Workbook
    Dim wbkDest As Workbook
    
    dirHome = "C:\Users\Denis\Documents\Test harvest" 'the consolidation folder
    dirAway = "C:\Users\Denis\Documents\Testing" 'the folder with all the files
    
    'Because you can't open 2 files with the same name (even in different folders)
    'the consolidation files need to be differently named.
    'In this case each has T_ added to the front of the name.
    'The code ignores the first 2 chars when searching for the matching file.
    
    File = Dir$(dirHome & "\T_*.xls")
    Do While Len(File)
        Workbooks.Open (File)
    
        Set wbkDest = ActiveWorkbook
        
        'Set objFSO = CreateObject("Scripting.FileSystemObject")
        Set objFSO = New Scripting.FileSystemObject
        Set objFldr = objFSO.GetFolder(dirAway)
        For Each objSubFldr In objFldr.SubFolders
            'open each workbook and copy data to Sheet1 in the destination workbook.
            Set wbkSource = Workbooks.Open(objSubFldr & "\" & Mid(ActiveWorkbook.Name, 3))
            Range("A1").CurrentRegion.Copy _
                Destination:=wbkDest.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
            wbkSource.Close SaveChanges:=False
        Next objSubFldr
        
        wbkDest.Close SaveChanges:=True
        Set wbkDest = Nothing
        
        File = Dir$
    Loop
    
    'clean up references
    Set objFldr = Nothing
    Set objFSO = Nothing
End Sub

Change the names of the home and away folders to suit.
Put a 2-character prefix on the names of the files in the consolidation folder.
Tested with a small number of files and folders; the loop works. No need for arrays.

Denis

 

[AnilPullagura]

Thanks Sydney Geek for your time and effort. Just checked the blog now.

I tested the code and it seems fine except for:

The thing is that i dont have all the spreadsheet in the "Home" folder. The folder layout is something like this.

I have a Main Folder(Home as mentioned by you). Inside this folder there are 15 folders for each employee by their name. Inside each employee folder there are 12 workbooks.

The code supplied by you seems to look within the Main Folder(HOME) for .xls files. Please let me know how I can incorporate the below code with yours to extract data.

Sub SubFoldersFiles(Folder)
Dim objfilename As String
objfilename = wkshtnames
    For Each SubFolder In Folder.SubFolders
        Set objFolder = objFSO.GetFolder(SubFolder.Path)
        For Each FileName In objFolder.Files
            If Not FileName.Name Like objfilename & "*" Then
                i = i + 1
                ReDim Preserve k(1 To i)
                k(i) = objFolder & "\" & FileName.Name
            End If
        Next
        SubFoldersFiles SubFolder
    Next
End Sub

 

[SydneyGeek]

That's not how I interpreted the question. Maybe I got it wrong but...

I have another consolidation Folder name “July – Consolidated” and in this folder I have the same 12 workbooks having similar naming conventions.

... doesn't mention 15 subfolders, just the files that will hold the consolidated data.

So, if you loop through 180 workbooks in Home and its subfolders, harvesting 180 workbooks in Away and its subdirectories, where is the consolidation happening? Or do you loop through a July set, then in August loop through those and build a consolidation for the year?

I want to be sure because it takes a while to build the code and I don't want to waste your time or mine.

Denis

 

[AnilPullagura]

Hey Denis,

I apologise for not being clear on my requirements, I will give it a final shot.

I have 2 Main Folders

1. July - Consolidated :- Having only 12 workbooks and no SubDirectories/SubFolders. These 12 workbooks are the consolidating workbooks

2 July - Entire Team :- This folder has 15 SubFolders and Each subFolder has 12 workbooks with the same names of those in the "July - Consolidated" Folder

Now my requirement is that the macro should open each workbook under "July - Consolidated" Folder, Search for excel workbooks with same name in "July - Entire Team" and its SUBFOLDERS and then extract the data to the Workbook in "July - Consolidated" Folder.

The code you have given is working well if there are no SubFolders in the Directory "July - Entire Team". I deduced that there should be a code which will search SUBFOLDERS apart from searching only the Folder "July - Entire Team".

I think the code will not take much time to run as I have created some macros which can consolidate data from multiple workbooks to a single WB and not consume much time.

Help Required on this Dennis!!!.

Its beyond my programming knowledge and this will help me in improving my VBA skills as well. Thanks once again for your time.

Regards,
Anil

 

[AnilPullagura]

BUMP!!! Incase if anyone of you can solve this for me