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!

 

[moshc]

It's me again! Need additional help on the vba code provided please. the sheets i'm trying to copy are protected and i'm having error prompt when executing the command. please anyone?

never mind already solved thanks

 

[jskasango]

Open a blank workbook, place this macro in a standard module and save the workbook as a macro-enabled file. Run the macro.

Sub CopySheets()
    Application.ScreenUpdating = False
    Dim MyFolder As String, MyFile As String, srcWB As Workbook, desWB As Workbook
    Set desWB = ThisWorkbook
    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
    MyFile = Dir(MyFolder)
    Do While MyFile <> ""
        Set srcWB = Workbooks.Open(Filename:=MyFolder & "\" & MyFile)
        With srcWB
            .Sheets(1).Copy desWB.Sheets(desWB.Sheets.Count)
            .Close False
        End With
        MyFile = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

This ALMOST what I am looking for, except that my source worksheet is named "Stocklist", the data starts at row 25 and should be vertically appended instead of creating a now sheet for every workbook found in the folder/subfolder. Should skip non excel files.

 

[mumps]

In which columns in "Stocklist" is the data to copy?

 

[jskasango]

In which columns in "Stocklist" is the data to copy?

From Column A to the last used column. To be pasted to Column B in the destination so that Column A of destination contains the name of the source workbook. In the source "Stocklist", data starts at Row 25. Thanks - Kasango

 

[mumps]

Change the file extension (in red) to suit your needs.

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wsDest As Worksheet, wkbSource As Workbook, FolderName As String, lCol As Long, lRow As Long
    Set wsDest = ThisWorkbook.Sheets("Sheet1")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Please select a folder"
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count = 0 Then
             MsgBox "You did not select a folder."
             Exit Sub
        End If
        FolderName = .SelectedItems(1) & "\"
    End With
    ChDir FolderName
    strExtension = Dir("*.xlsx")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(FolderName & strExtension)
        With Sheets("Sheet1")
            lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            lCol = .Cells(25, Columns.Count).End(xlToLeft).Column
            .Range("A25").Resize(lRow - 25, lCol).Copy wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1)
            wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Resize(lRow - 25) = wkbSource.Name
        End With
        wkbSource.Close False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[jskasango]

THANKS! This works very well. The code was hanging when it did not find the sheet "EntryList" so I placed "On Error Resume Next" above the point where it stopped, and that seems to have fixed it.
Can I please have it pick the headers once? They are at Row1 of the source WB.
At Column A of destination, can I have it write the source folder in addition to the WBname without the extension *.XLS* and rename the destination Sheet as a new WB <FolderName-sourceSheetname?
Once it does that, I will be completely sorted out!
These are the little changes that I made:

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wsDest As Worksheet, wkbSource As Workbook, FolderName As String, lCol As Long, lRow As Long
    Set wsDest = ThisWorkbook.Sheets("Sheet1")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Please select a folder"
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count = 0 Then
             MsgBox "You did not select a folder."
             Exit Sub
        End If
        FolderName = .SelectedItems(1) & "\"
    End With
    ChDir FolderName
    strExtension = Dir("*.xls*")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(FolderName & strExtension)
       On Error Resume Next
        With Sheets("Entrylist")
            lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            lCol = .Cells(25, Columns.Count).End(xlToLeft).Column
            .Range("A25").Resize(lRow - 25, lCol).Copy wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1)
            wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Resize(lRow - 25) = wkbSource.Name
        End With
        wkbSource.Close False
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[mumps]

Do you want the data from each source sheet copied to its own separate sheet instead of all to the same sheet?

rename the destination Sheet as a new WB <FolderName-sourceSheetname?

Does this mean: workbook name-folder name-source sheet name? If you want to use this as the sheet name, keep in mind that a sheet name cannot exceed more than 31 characters.

 

[jskasango]

Do you want the data from each source sheet copied to its own separate sheet instead of all to the same sheet?

Does this mean: workbook name-folder name-source sheet name? If you want to use this as the sheet name, keep in mind that a sheet name cannot exceed more than 31 characters.

The maximum will be something like this filename "KB21A-0A999". KB21A being the folderName and 0A999 being the workbookName. The sheet will be "KB21A-EntryList".

 

[mumps]

You should avoid using "on error resume next" if possible because it will apply to any error that may occur. You should instead error check the specific problem which in your case is the existence of sheet "EntryList". The line of code in red does this. If the sheet doesn't exist, the code will go to the next file.

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wsDest As Worksheet, wkbSource As Workbook, FolderName As String, lCol As Long, lRow As Long, FN As String, wbName As String
    Set wsDest = ThisWorkbook.Sheets("Sheet1")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Please select a folder"
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count = 0 Then
             MsgBox "You did not select a folder."
             Exit Sub
        End If
        FolderName = .SelectedItems(1) & "\"
    End With
    ChDir FolderName
    strExtension = Dir("*.xlsx")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(FolderName & strExtension)
        FN = Mid(Replace(FolderName, "\", ""), 3, 9999)
        wbName = Split(wkbSource.Name, ".")(0)
        If Not IsError(Evaluate("=ISREF('[" & wkbSource.Name & "]" & "EntryList" & "'!$A$1)")) Then
            With Sheets("Entrylist")
                lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                lCol = .Cells(25, Columns.Count).End(xlToLeft).Column
                .Range("A25").Resize(lRow - 25, lCol).Copy wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1)
                wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Resize(lRow - 25) = FN & "-" & wbName
            End With
        End If
        wkbSource.Close False
        strExtension = Dir
    Loop
    wsDest.Name = FN & "-EntryList"
    Application.ScreenUpdating = True
End Sub

 

[jskasango]

You should avoid using "on error resume next" if possible because it will apply to any error that may occur. You should instead error check the specific problem which in your case is the existence of sheet "EntryList". The line of code in red does this. If the sheet doesn't exist, the code will go to the next file.

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wsDest As Worksheet, wkbSource As Workbook, FolderName As String, lCol As Long, lRow As Long, FN As String, wbName As String
    Set wsDest = ThisWorkbook.Sheets("Sheet1")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Please select a folder"
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count = 0 Then
             MsgBox "You did not select a folder."
             Exit Sub
        End If
        FolderName = .SelectedItems(1) & "\"
    End With
    ChDir FolderName
    strExtension = Dir("*.xlsx")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(FolderName & strExtension)
        FN = Mid(Replace(FolderName, "\", ""), 3, 9999)
        wbName = Split(wkbSource.Name, ".")(0)
        If Not IsError(Evaluate("=ISREF('[" & wkbSource.Name & "]" & "EntryList" & "'!$A$1)")) Then
            With Sheets("Entrylist")
                lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                lCol = .Cells(25, Columns.Count).End(xlToLeft).Column
                .Range("A25").Resize(lRow - 25, lCol).Copy wsDest.Cells(wsDest.Rows.Count, "B").End(xlUp).Offset(1)
                wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Resize(lRow - 25) = FN & "-" & wbName
            End With
        End If
        wkbSource.Close False
        strExtension = Dir
    Loop
    wsDest.Name = FN & "-EntryList"
    Application.ScreenUpdating = True
End Sub

Wonderful! The headers are still missing. They are to be found on Row 1 of the first WB with "EntryList" sheet.
The contents of Column A in the destination worksheet have picked the complete address from the Root(CIMKEN\FBK\Nursery\KB21B-0B02) "0B02" being the WorkbookName. I just need the folderName and the WorkbookNmae eg KB21B-0B02.
Would you know why I am not seeing the MrExcel button for SOLVED? I believe I need it at your next response.