Excel masterfile vba

M

moshc

New Member
Joined
Oct 24, 2019
Messages
6
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!
 
Sort by date Sort by votes
Replace the current part of the code with this:
VBA Code: 
If Not IsError(Evaluate("=ISREF('[" & oFile.Name & "]" & "EntryList" & "'!$A$1)")) Then
                    If Sheets("EntryList").Range("A1") <> "" 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
                End If
Please note that the code checks to see if cell A1 in EntryList has data.
 
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
I will change that to A25 because that is where the data starts. Right?
mumps said:
Replace the current part of the code with this:
VBA Code: 
If Not IsError(Evaluate("=ISREF('[" & oFile.Name & "]" & "EntryList" & "'!$A$1)")) Then
                    If Sheets("EntryList").Rang[B][COLOR=rgb(209, 72, 65)]e("A25")[/COLOR][/B] <> "" 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
                End If
Please note that the code checks to see if cell A1 in EntryList has data.
Click to expand...
 
Upvote 0
When replace I get this.

VBA Code: 
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, 3) Like "xl*" 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
                 [B][COLOR=rgb(209, 72, 65)]   If Sheets("EntryList").Rang[B][COLOR=rgb(209, 72, 65)]e("A25")[/COLOR][/B] <> "" Then[/COLOR][/B]
                        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
                End If
                wkbSource.Close False
            End If
        Next oFile
    Loop
    '=================================
    wsDest.Name = "2019A" & "-EntryLists"
   ' ActiveWorkbook.SaveAs FileName:=FolderPath & FN & "-" & "EntryLists", FileFormat:=xlCSV, CreateBackup:=False
    ActiveWorkbook.SaveAs FileName:="2019A" & "-" & "EntryLists", FileFormat:=xlCSV, CreateBackup:=False
    
    Rows("1:1").Select
    Selection.AutoFilter
    Rows("2:2").Select
    ActiveWindow.FreezePanes = True
    Application.ScreenUpdating = True
    Application.ScreenUpdating = True
    '=================================
End Sub

Data starts at Row 25 ie It should check "A25". What is the coloring for? Thanks. -Kasango
 
Upvote 0
jskasango said:
When replace I get this.

VBA Code: 
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, 3) Like "xl*" 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
                 [B][COLOR=rgb(209, 72, 65)]   If Sheets("EntryList").Rang[B][COLOR=rgb(209, 72, 65)]e("A25")[/COLOR][/B] <> "" Then[/COLOR][/B]
                        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
                End If
                wkbSource.Close False
            End If
        Next oFile
    Loop
    '=================================
    wsDest.Name = "2019A" & "-EntryLists"
   ' ActiveWorkbook.SaveAs FileName:=FolderPath & FN & "-" & "EntryLists", FileFormat:=xlCSV, CreateBackup:=False
    ActiveWorkbook.SaveAs FileName:="2019A" & "-" & "EntryLists", FileFormat:=xlCSV, CreateBackup:=False
   
    Rows("1:1").Select
    Selection.AutoFilter
    Rows("2:2").Select
    ActiveWindow.FreezePanes = True
    Application.ScreenUpdating = True
    Application.ScreenUpdating = True
    '=================================
End Sub

Data starts at Row 25 i.e. It should check "A25". What is the coloring for? Thanks. -Kasango
Click to expand...
I inserted "2019" manually because I am yet to pick the parent folder with code but still trying.
 
Upvote 0
jskasango said:
I inserted "2019" manually because I am yet to pick the parent folder with code but still trying.
Click to expand...
The code should save the output workbook inside the parent (selected) folder instead of outside. Thanks!
 
Upvote 0
Try:
VBA Code: 
ActiveWorkbook.SaveAs FileName:=MyFolder & FN & "-" & "EntryLists", FileFormat:=xlCSV, CreateBackup:=False
 
Upvote 0
mumps said:
Try:
VBA Code: 
ActiveWorkbook.SaveAs FileName:=MyFolder & FN & "-" & "EntryLists", FileFormat:=xlCSV, CreateBackup:=False
Click to expand...
Could you kindly send me back the code after editing the issue of the "EntryList" without data? Thanks- Kasango.
 
Upvote 0
VBA Code: 
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, 3) Like "xl*" 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
                    If Sheets("EntryList").Range("A25") <> "" 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
                End If
                wkbSource.Close False
            End If
        Next oFile
    Loop
    '=================================
    wsDest.Name = "2019A" & "-EntryLists"
   ' ActiveWorkbook.SaveAs FileName:=MyFolder & FN & "-" & "EntryLists", FileFormat:=xlCSV, CreateBackup:=False
    ActiveWorkbook.SaveAs Filename:="2019A" & "-" & "EntryLists", FileFormat:=xlCSV, CreateBackup:=False
   
    Rows("1:1").Select
    Selection.AutoFilter
    Rows("2:2").Select
    ActiveWindow.FreezePanes = True
    Application.ScreenUpdating = True
    Application.ScreenUpdating = True
    '=================================
End Sub
 
Upvote 0
Working great even with Ws without data! Trying to workaround the 31 character limitation for "MyFolder". I need the last 5 characters of "MyFolder". This is GREAT!
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question
Combine Multiple Sheets from a Folder to create a masterfile
Replies
3
Views
110
rlv01
R
J
  • Question
VBA Script - Can't figure out one error...
2
Replies
15
Views
364
Peter_SSs
Peter_SSs
A
  • Question
Excel data from one sheet, copy cells from row i'm working on to excel 'form' based on cell value
Replies
2
Views
71
asiuol84
A
I
  • Question
VBA - Copy Sheet from a workbook saved as a date - paste to specifically named sheet in another workbook based on the date
Replies
2
Views
366
Insurance Dave
I
S
  • Question
VBA Challenge
Replies
2
Views
293
SnowyBry
S

Forum statistics

Threads
1,216,054
Messages
6,128,516
Members
449,456
Latest member
SammMcCandless

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