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

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
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

S
  • Question Question
2 questions related to VBA
Replies
4
Views
85
Skyybot
Skyybot
C
  • Solved
Extracting data with VBA macro button from files in designated folder
2 3
Replies
20
Views
1K
Micron
M
A
  • Question Question
Open, Copy data and Close a workbook based on the names of the tabs in my active workbook
Replies
2
Views
137
Aurore87
A
B
  • Question Question
Update Variable Data from Multiple Worksheets in a Master Sheet
2
Replies
11
Views
779
mumps
mumps
R
  • Question Question
Add a code or number at the end of the file name using VBA (Looped)
Replies
3
Views
122
HighAndWilder
H

Forum statistics

Threads
1,224,828
Messages
6,181,209
Members
453,023
Latest member
alabaz

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