Excel masterfile vba

[moshc]

Good day!

Anyone can help me please?

I've been looking for an EXCEL VBA code in which i will have the option to select a folder path first which all the workbooks i need to combined is saved and have all the first sheets in all workbook in that specific folder is then combined to a new workbook.

Would really much appreciate any immediate response.

Thank you!

 

[jskasango]

@mumps , It appears that the reason I do not have rights to indicate SOLVED is that I took a ride on somebody else's post. Kindly accept my sincere gratitude and appreciation. Thanks a lot - Kasango.

 

[mumps]

My pleasure.

 

[jskasango]

My pleasure.

Would it be too much if I asked you to please place a line that will make the code look in subfolders as well? Thanks in advance.

 

[mumps]

With this version, you won't have to do anything manually.

Public Sub NonRecursiveMethod()
    Application.ScreenUpdating = False
    Dim fso, oFolder, oSubfolder, oFile, queue As Collection, MyFolder As String
    Dim wsDest As Worksheet, wkbSource As Workbook, lCol As Long, lRow As Long
    Dim splt As Variant, FN As String, wbName As String, x As Long: x = 1
    Set wsDest = ThisWorkbook.Sheets("Sheet1")
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set queue = New Collection
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Please select a folder"
        .Show
        .AllowMultiSelect = False
        If .SelectedItems.Count = 0 Then
            MsgBox "You did not select a folder."
            Exit Sub
        End If
        MyFolder = .SelectedItems(1) & "\"
    End With
    queue.Add fso.GetFolder(MyFolder)
    Do While queue.Count > 0
        Set oFolder = queue(1)
        queue.Remove 1
        For Each oSubfolder In oFolder.SubFolders
            queue.Add oSubfolder
        Next oSubfolder
        For Each oFile In oFolder.Files
            Set wkbSource = Workbooks.Open(oFile)
            splt = Split(oFile, "\")
            FN = splt(UBound(splt) - 1)
            wbName = Split(wkbSource.Name, ".")(0)
            If Not IsError(Evaluate("=ISREF('[" & oFile.Name & "]" & "EntryList" & "'!$A$1)")) Then
                With Sheets("Sheet1")
                    If x = 1 Then
                        lCol = .Cells(1, Columns.Count).End(xlToLeft).Column
                        wsDest.Range("A1") = "NurseryName"
                        .Range("A1").Resize(, lCol).Copy wsDest.Range("B1")
                        x = x + 1
                        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                        .Range("A25").Resize(lRow - 24, lCol).Copy wsDest.Range("B2")
                        wsDest.Range("A2").Resize(lRow - 24) = FN & "-" & wbName
                    Else
                        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                        lCol = .Cells(25, Columns.Count).End(xlToLeft).Column
                        .Range("A25").Resize(lRow - 24, lCol).Copy wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1)
                        wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Resize(lRow - 24) = FN & "-" & wbName
                    End If
                End With
            End If
            wkbSource.Close False
        Next oFile
    Loop
    Application.ScreenUpdating = True
End Sub

 

[jskasango]

With this version, you won't have to do anything manually.

Public Sub NonRecursiveMethod()
    Application.ScreenUpdating = False
    Dim fso, oFolder, oSubfolder, oFile, queue As Collection, MyFolder As String
    Dim wsDest As Worksheet, wkbSource As Workbook, lCol As Long, lRow As Long
    Dim splt As Variant, FN As String, wbName As String, x As Long: x = 1
    Set wsDest = ThisWorkbook.Sheets("Sheet1")
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set queue = New Collection
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Please select a folder"
        .Show
        .AllowMultiSelect = False
        If .SelectedItems.Count = 0 Then
            MsgBox "You did not select a folder."
            Exit Sub
        End If
        MyFolder = .SelectedItems(1) & "\"
    End With
    queue.Add fso.GetFolder(MyFolder)
    Do While queue.Count > 0
        Set oFolder = queue(1)
        queue.Remove 1
        For Each oSubfolder In oFolder.SubFolders
            queue.Add oSubfolder
        Next oSubfolder
        For Each oFile In oFolder.Files
            Set wkbSource = Workbooks.Open(oFile)
            splt = Split(oFile, "\")
            FN = splt(UBound(splt) - 1)
            wbName = Split(wkbSource.Name, ".")(0)
            If Not IsError(Evaluate("=ISREF('[" & oFile.Name & "]" & "EntryList" & "'!$A$1)")) Then
                With Sheets("Sheet1")
                    If x = 1 Then
                        lCol = .Cells(1, Columns.Count).End(xlToLeft).Column
                        wsDest.Range("A1") = "NurseryName"
                        .Range("A1").Resize(, lCol).Copy wsDest.Range("B1")
                        x = x + 1
                        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                        .Range("A25").Resize(lRow - 24, lCol).Copy wsDest.Range("B2")
                        wsDest.Range("A2").Resize(lRow - 24) = FN & "-" & wbName
                    Else
                        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                        lCol = .Cells(25, Columns.Count).End(xlToLeft).Column
                        .Range("A25").Resize(lRow - 24, lCol).Copy wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1)
                        wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Resize(lRow - 24) = FN & "-" & wbName
                    End If
                End With
            End If
            wkbSource.Close False
        Next oFile
    Loop
    Application.ScreenUpdating = True
End Sub

I am trying it. It kept stopping at the blue circle then I edited it to read "Entrylist" instead of "Sheet1" and now it has this:-

 

[mumps]

It kept stopping at the blue circle then I edited it to read "Entrylist" instead of "Sheet1" and now it has this:-

My apologies. I forgot to make that change after testing.
I also forgot to test for Excel files only. Try:

Public Sub NonRecursiveMethod()
    Application.ScreenUpdating = False
    Dim fso, oFolder, oSubfolder, oFile, queue As Collection, MyFolder As String
    Dim wsDest As Worksheet, wkbSource As Workbook, lCol As Long, lRow As Long
    Dim splt As Variant, FN As String, wbName As String, x As Long: x = 1
    Set wsDest = ThisWorkbook.Sheets("Sheet1")
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set queue = New Collection
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Please select a folder"
        .Show
        .AllowMultiSelect = False
        If .SelectedItems.Count = 0 Then
            MsgBox "You did not select a folder."
            Exit Sub
        End If
        MyFolder = .SelectedItems(1) & "\"
    End With
    queue.Add fso.GetFolder(MyFolder)
    Do While queue.Count > 0
        Set oFolder = queue(1)
        queue.Remove 1
        For Each oSubfolder In oFolder.SubFolders
            queue.Add oSubfolder
        Next oSubfolder
        For Each oFile In oFolder.Files
            If Right(oFile, 4) Like "xls*" Then
                Set wkbSource = Workbooks.Open(oFile)
                splt = Split(oFile, "\")
                FN = splt(UBound(splt) - 1)
                wbName = Split(wkbSource.Name, ".")(0)
                If Not IsError(Evaluate("=ISREF('[" & oFile.Name & "]" & "EntryList" & "'!$A$1)")) Then
                    With Sheets("EntryList")
                        If x = 1 Then
                            lCol = .Cells(1, Columns.Count).End(xlToLeft).Column
                            wsDest.Range("A1") = "NurseryName"
                            .Range("A1").Resize(, lCol).Copy wsDest.Range("B1")
                            x = x + 1
                            lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                            .Range("A25").Resize(lRow - 24, lCol).Copy wsDest.Range("B2")
                            wsDest.Range("A2").Resize(lRow - 24) = FN & "-" & wbName
                        Else
                            lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                            lCol = .Cells(25, Columns.Count).End(xlToLeft).Column
                            .Range("A25").Resize(lRow - 24, lCol).Copy wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1)
                            wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Resize(lRow - 24) = FN & "-" & wbName
                        End If
                    End With
                End If
                wkbSource.Close False
            End If
        Next oFile
    Loop
    Application.ScreenUpdating = True
End Sub

 

[jskasango]

My apologies. I forgot to make that change after testing.
I also forgot to test for Excel files only. Try:

Public Sub NonRecursiveMethod()
    Application.ScreenUpdating = False
    Dim fso, oFolder, oSubfolder, oFile, queue As Collection, MyFolder As String
    Dim wsDest As Worksheet, wkbSource As Workbook, lCol As Long, lRow As Long
    Dim splt As Variant, FN As String, wbName As String, x As Long: x = 1
    Set wsDest = ThisWorkbook.Sheets("Sheet1")
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set queue = New Collection
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Please select a folder"
        .Show
        .AllowMultiSelect = False
        If .SelectedItems.Count = 0 Then
            MsgBox "You did not select a folder."
            Exit Sub
        End If
        MyFolder = .SelectedItems(1) & "\"
    End With
    queue.Add fso.GetFolder(MyFolder)
    Do While queue.Count > 0
        Set oFolder = queue(1)
        queue.Remove 1
        For Each oSubfolder In oFolder.SubFolders
            queue.Add oSubfolder
        Next oSubfolder
        For Each oFile In oFolder.Files
            If Right(oFile, 4) Like "xls*" Then
                Set wkbSource = Workbooks.Open(oFile)
                splt = Split(oFile, "\")
                FN = splt(UBound(splt) - 1)
                wbName = Split(wkbSource.Name, ".")(0)
                If Not IsError(Evaluate("=ISREF('[" & oFile.Name & "]" & "EntryList" & "'!$A$1)")) Then
                    With Sheets("EntryList")
                        If x = 1 Then
                            lCol = .Cells(1, Columns.Count).End(xlToLeft).Column
                            wsDest.Range("A1") = "NurseryName"
                            .Range("A1").Resize(, lCol).Copy wsDest.Range("B1")
                            x = x + 1
                            lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                            .Range("A25").Resize(lRow - 24, lCol).Copy wsDest.Range("B2")
                            wsDest.Range("A2").Resize(lRow - 24) = FN & "-" & wbName
                        Else
                            lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                            lCol = .Cells(25, Columns.Count).End(xlToLeft).Column
                            .Range("A25").Resize(lRow - 24, lCol).Copy wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1)
                            wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Resize(lRow - 24) = FN & "-" & wbName
                        End If
                    End With
                End If
                wkbSource.Close False
            End If
        Next oFile
    Loop
    Application.ScreenUpdating = True
End Sub

Testing but not seeing any activity. While I wait for your time zone, I will use the previous code after moving away all non-Excel files in the folder and subf0lders. It works perfect! I will wait for you. Thanks so much for your trouble. -Kasango.

 

[mumps]

not seeing any activity

What do you mean by this? Are any of the files being opened? I tested the macro and it worked properly. It should open the files in the folder that you choose in the pop up and then open the files in the sub folders within the originally chosen folder.

 

[jskasango]

What do you mean by this? Are any of the files being opened? I tested the macro and it worked properly. It should open the files in the folder that you choose in the pop up and then open the files in the sub folders within the originally chosen folder.

@mumps , sorry for not being clear. I tested your last version and it runs without any error. Since it did not populate the destination WB, I executed it using F8 and went slowly by slowly using a trick I leaned from a friend which entails hovering the cursor on the various steps of the code to see what it has in memory at that point. I watched it look at each and every file in the folder and sub folder, including non-excel files! Alas! When it finished running, the destination WB was still blank. Unless you have directed the output elsewhere? Sorry for the little setback.

 

[mumps]

When I tested the macro using a couple of dummy workbooks, it worked properly. The output is directed to Sheet1 of the workbook containing the macro. It is hard for me to see why it is not working for you because I don't have access to your actual files. Check to make sure that all the source workbooks have a sheet named ""EntryList".