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]

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.

No. Let it all be stacked in one sheet. You are very right, I do not need the Workbook name in the Summary sheet and Saved final file, It should be named "FolderName-'EntryList'". I can manually copy the headers into Row 1 of the destination sheet but if you can "fish" them for me, the better. Thanks- Kasango.

 

[jskasango]

@mumps ! I have played around and managed to solve column A and DestinationSheetName issues! I am surprised by myself!
What is the only thing remaining is collecting the headers into the destination sheet!
Thanks a million!

 

[jskasango]

@mumps ! I have played around and managed to solve column A and DestinationSheetName issues! I am surprised by myself!
What is the only thing remaining is collecting the headers into the destination sheet!
Thanks a million!

SOS! @mumps , the code seems to mismatch the contents of Column A when writing this line =wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Resize(lRow - 25) = FN & "-" & wbName. You find that it fills information from the next WB into rows belonging to the previous WB. Can we correct that? Actually for each WB opened, it skips the last row of the data range.

 

[mumps]

Does the data that is copied always start on row 25 in each source workbook?

 

[jskasango]

Yes, all the time.

 

[mumps]

I tested this macro with two dummy source workbooks and it works properly. It also copies the headers from row 1. It also assumes that the data to be copied always starts at row 25.

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wsDest As Worksheet, wkbSource As Workbook, FolderName As String, 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")
    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)
        splt = Split(FolderName, "\")
        FN = splt(UBound(splt) - 1)
        wbName = Split(wkbSource.Name, ".")(0)
        If Not IsError(Evaluate("=ISREF('[" & wkbSource.Name & "]" & "EntryList" & "'!$A$1)")) Then
            With Sheets("Entrylist")
                If x = 1 Then
                    .Rows(1).EntireRow.Copy wsDest.Range("A1")
                    x = x + 1
                    lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                    lCol = .Cells(25, Columns.Count).End(xlToLeft).Column
                    .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
        strExtension = Dir
    Loop
    wsDest.Name = FN & "-EntryList"
    Application.ScreenUpdating = True
End Sub

 

[jskasango]

I tested this macro with two dummy source workbooks and it works properly. It also copies the headers from row 1. It also assumes that the data to be copied always starts at row 25.

Sub CopyRange()
    Application.ScreenUpdating = False
    Dim wsDest As Worksheet, wkbSource As Workbook, FolderName As String, 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")
    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)
        splt = Split(FolderName, "\")
        FN = splt(UBound(splt) - 1)
        wbName = Split(wkbSource.Name, ".")(0)
        If Not IsError(Evaluate("=ISREF('[" & wkbSource.Name & "]" & "EntryList" & "'!$A$1)")) Then
            With Sheets("Entrylist")
                If x = 1 Then
                    .Rows(1).EntireRow.Copy wsDest.Range("A1")
                    x = x + 1
                    lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                    lCol = .Cells(25, Columns.Count).End(xlToLeft).Column
                    .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
        strExtension = Dir
    Loop
    wsDest.Name = FN & "-EntryList"
    Application.ScreenUpdating = True
End Sub

Now even before I test, where has the solved button gone!? Don't worry, I will find it.

 

[jskasango]

I dont know what you have done, I wish the code had notes, but whatever youve done makes it run like lightning!!!!!!!
A million thanks! If you were from near me, this qualifies you to be treated to a whole Bar-B-Q!!!!

 

[mumps]

You are very welcome. A Bar-B-Q would be great but your thanks are more than enough?

 

[jskasango]

You are very welcome. A Bar-B-Q would be great but your thanks are more than enough?

@mumps To honour you, I have named the code "MumpsMergeLists"! Kkkkkkk. The headers are great, I only need to manually move them one cell to the right, then label Range A1 "NurseryName". Now am on my way to the MrExccel Admins to get back my "SOLVED" button!