Use a master "extractor" workbook to retrieve a specific sheet in multiple workbooks

[Yupanqi]

Hello everyone

I am a bit stuck on my current project and after searching these forums I got encouraged to post my question.

Lets say I have some Workbooks saved in a specific path (C:\Workbooks). Each Workbook has a different name and within each Workbook there is a Sheet called "Final Results". This sheet name is constant across all Workbooks.

What I am looking for is a master Workbook that will copy the entire "Final Results" sheet from each workbook in the path. However, I need for each copied sheet to be named exactly as the workbook it was copied from.

I found a piece of VBA code that does most of the work but I cannot seem to tweak it to meet these additional details I am mentioning.

Option Explicit
Private Enum TextChoice
    Save_Rejected = -1
    Folder_NotPicked = 0
    SheetExist_False = 1
End Enum

Function Folder_Picker(Optional BttnText As String = "OK", _
                       Optional IniFolName As String, _
                       Optional IniView As MsoFileDialogView = _
                                                msoFileDialogViewList, _
                       Optional TitleText As String _
                       ) As Variant
Dim FldPic As FileDialog
    Set FldPic = Application.FileDialog(msoFileDialogFolderPicker)
    
    With FldPic
        .AllowMultiSelect = False
        .ButtonName = BttnText
        .InitialFileName = IniFolName
        .InitialView = IniView
        .Title = TitleText
        
        If .Show = -1 Then
            Folder_Picker = .SelectedItems(1)
        Else
            Folder_Picker = "False"
        End If
    End With
End Function
Function BrowseForFolder(Optional OpenAt As Variant, _
                         Optional TitleBarText As String = _
                            "Please choose a folder" _
                         ) As Variant
'//*************************************************************************//
'//                                                                         //
'// Acknowledgement:    BrowseForFolder was taken from a kb entry at        //
'//                     vbaexpress, I am almost certain the author of which //
'//                     was DRJ.  Unfortunately, I cannot recall the exact  //
'//                     kb entry.                                           //
'//*************************************************************************//
     'Function purpose:  To Browser for a user selected folder.
     'If the "OpenAt" path is provided, open the browser at that directory
     'NOTE:  If invalid, it will open at the Desktop level
     
    Dim ShellApp As Object
     
     'Create a file browser window at the default folder
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, TitleBarText, 0, OpenAt)
     
     'Set the folder to that selected.  (On error in case cancelled)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
     
     'Destroy the Shell Application
    Set ShellApp = Nothing
     
     'Check for invalid or non-entries and send to the Invalid error
     'handler if found
     'Valid selections can begin L: (where L is a letter) or
     '\\ (as in \\servername\sharename.  All others are invalid
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else
        GoTo Invalid
    End Select
     
    Exit Function
     
Invalid:
     'If it was determined that the selection was invalid, set to False
    BrowseForFolder = False
     
End Function

Private Function MsgAdvise(TextPick As TextChoice, _
                      Optional vb_MsgStyle As VbMsgBoxStyle = 0, _
                      Optional MsgTitle As String = "User Message", _
                      Optional FileName As String) As VbMsgBoxResult
Dim strText         As String
    
    Select Case TextPick
        Case Save_Rejected
            strText = "You chose to Cancel saving the new workbook.  " & _
                      "Operation cancelled."
        Case Folder_NotPicked
            strText = "A valid folder must be selected.  Operation cancelled."
        Case SheetExist_False
            strText = "The workbook: """ & FileName & """ does not have a " & _
                      "worksheet named ""ro24.""" & vbCrLf & _
                      "The next workbook will now be checked."
    End Select
    MsgBox strText, vb_MsgStyle, MsgTitle
        
End Function

Sub GetXLSData_MultiWorkbooks()
'// Declare File System Object related as variants.                                     //
Dim fs, foc, fc, fi
Dim wb                      As Workbook
Dim wbNewBook               As Workbook
Dim wksSource               As Worksheet
Dim strFolName              As String
Dim strThisWBPath           As String
Dim strNewWB_PathOrFNam     As String
    Set wbNewBook = Workbooks.Add(xlWBATWorksheet)
    
    strThisWBPath = ThisWorkbook.Path & Application.PathSeparator
    ChDir strThisWBPath
    
    strNewWB_PathOrFNam = Application.GetSaveAsFilename( _
                        InitialFileName:=strThisWBPath & "Summary", _
                        FileFilter:= _
                            "Microsoft Office Excel Workbook(*.xls), *.xls", _
                        Title:="Choose a name for the new Workbook")
    
    If strNewWB_PathOrFNam = "False" Then
        wbNewBook.Close SaveChanges:=False
        Call MsgAdvise(Save_Rejected, vbInformation + vbOKOnly)
        Exit Sub
    Else
        Application.DisplayAlerts = False
        wbNewBook.SaveAs FileName:=strNewWB_PathOrFNam, _
                         FileFormat:=xlNormal, _
                         AddToMru:=False
        Application.DisplayAlerts = True
    End If
    
'//*************************************************************************//
'// To use 'BrowseForFolder', un-rem this code and change                   //
'// 'ThisWorkbook.Path' to the path you want the Browser to start at (such  //
'// as: C:\Users\davez\AppData\Roaming\Microsoft\Excel\XLSTART              //
'// OR                                                                      //
'// If you want to try folderpicker, see farther down.                      //
'    strNewWB_PathOrFNam = ThisWorkbook.Path
'
'    strFolName = BrowseForFolder(strNewWB_PathOrFNam & _
'                                 Application.PathSeparator, _
'                                    "Choose the Folder that the" & vbCrLf _
'                                    & "multiple workbooks are in.")
'//*************************************************************************//
    
    
'//*************************************************************************//
'// Similar to above, but we're just passing the path directly as an arg    //
'// Change to suite, such as:                                               //
'// C:\Users\davez\AppData\Roaming\Microsoft\Excel\XLSTART                  //
'//*************************************************************************//
    strFolName = Folder_Picker("Run", "G:\FSO Examples\", , _
                               "Pick the folder the files are in, " & _
                               "then click .")
'//*************************************************************************//
    
    
    '// In case no folder was chosen                                        //
    If strFolName = "False" Then
        Call MsgAdvise(Folder_NotPicked, vbInformation + vbOKOnly)
        wbNewBook.Close SaveChanges:=False
        Exit Sub
    Else
        strFolName = strFolName & Application.PathSeparator
    End If
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set foc = fs.GetFolder(strFolName)
    Set fc = foc.Files
    For Each fi In fc
        If Not ThisWorkbook.Name = fi.Name Then
            Set wb = Application.Workbooks.Open(FileName:=strFolName & _
                                                          fi.Name, _
                                                ReadOnly:=True, _
                                                AddToMru:=False)
            Err.Clear
            On Error Resume Next
            Set wksSource = wb.Worksheets("Sheet1")
            
            If Not Err.Number = 0 Then
                wb.Close SaveChanges:=False
                Call MsgAdvise(SheetExist_False, _
                               vbCritical, "WARNING!", _
                               fi.Name)
            Else
                wksSource.Copy After:=wbNewBook.Worksheets( _
                                    wbNewBook.Worksheets.Count)
                wb.Close SaveChanges:=False
            End If
            On Error GoTo 0
        End If
    Next
    If wbNewBook.Worksheets.Count > 1 Then
        Application.DisplayAlerts = False
        wbNewBook.Worksheets(1).Delete
        Application.DisplayAlerts = True
    End If
    
    wbNewBook.Save
    Set wb = Nothing
    Set wbNewBook = Nothing
    Set wksSource = Nothing
End Sub

Any help in order to help me solve this would be greatly appreciated.

Thanks a lot in advance.
Yupanqi

 

[Norie]

Perhaps something like this.

Sub GetFinalResults()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim strFilename As String
Dim strPath As String


        Set wbDst = ThisWorkbook

        strPath = "C:\Workbooks"

        strFilename = Dir(strPath & "\*.xl*")

        While Len(strFilename)>0 

                 If strFilename <> wbDst.Name Then

                      Set wbSrc = Workbooks.Open(strPath & "\" & strFilename)
                      
                      wbSrc.Worksheets("Final Results").Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)

                      wbDst.Worksheets(wbDst.Worksheets.Count).Name = strFilename

                      wbSrc.Close SaveChanges:=False

                 End if

                 strFilename = Dir
       Wend

End Sub

 

[Yupanqi]

Awesome and lightning fast reply, thank you!