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

Yupanqi

New Member
Joined
Feb 6, 2013
Messages
2
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.

Code:
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
 

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.

Norie

Well-known Member
Joined
Apr 28, 2004
Messages
76,300
Office Version
  1. 365
Platform
  1. Windows
Perhaps something like this.
Code:
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
 

Forum statistics

Threads
1,136,788
Messages
5,677,738
Members
419,716
Latest member
MPunt

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
Top