VBA Code to select a variable folder path, find multiple .xls then copy same named worksheets into new workbook.

[SteveD01]

Hi all. I have the following code that attempts to allows me to select a variable folder path (as the folder name is changed month to month) where it will find multiple .xls. it then opens each workbook and copies the "Report" worksheet from each into a new single workbook.

Separately I can create a defined Const strfolder and get that folder to open but the variable option just does not want to work.

Please help!

Sub Combine_Status_Reports()

' Use this macro to combine worksheets of the same name from multiple workbooks

Dim strFolder As FileDialog
Dim strFile As String
Dim wbkSource As Workbook
Dim wbkTarget As Workbook
Dim ws As Worksheet

' Folder Picker

Set strFolder = Application.FileDialog(msoFileDialogFolderPicker)

With strFolder
.Title = "Select Folder"
.AllowMultiSelect = False
End With
  
If strFolder.SelectedItems.Count = 0 Then
MsgBox "No Files in Folder. Pick Another Folder"
End If

' Open new workbook and copy 'Report' worksheet from all workbooks to new workbook

Application.ScreenUpdating = False

Set wbkTarget = Workbooks.Add(Template:=xlWBATWorksheet)
strFile = Dir(strFolder & "*.xls*")
Do While strFile <> ""
Set wbkSource = Workbooks.Open(Filename:=strFolder & strFile, ReadOnly:=True)
wbkSource.Worksheets("Report").Copy After:=wbkTarget.Worksheets(1)
wbkSource.Close savechanges:=False
strFile = Dir

Loop

Application.DisplayAlerts = False
wbkTarget.Worksheets(1).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True

' Check and replace new worksheet names with project name

For Each ws In Worksheets
    On Error Resume Next
    If Len(ws.Range("C3")) > 0 Then
        ws.Name = Replace(ws.Range("C3").Value, "/", "-")
    End If
    On Error GoTo 0
    If Len(ws.Range("C3")) > 31 Then
        ws.Name = Left(ws.Range("C3"), 31)
    End If
    If Len(ws.Range("C3")) = 0 Then
        MsgBox "No REPORT sheet found in " & wbkSource
    End If

Next

End Sub

 

[John_w]

Replace:

Dim strFolder As FileDialog
Dim strFile As String
Dim wbkSource As Workbook
Dim wbkTarget As Workbook
Dim ws As Worksheet

' Folder Picker

Set strFolder = Application.FileDialog(msoFileDialogFolderPicker)

With strFolder
.Title = "Select Folder"
.AllowMultiSelect = False
End With
  
If strFolder.SelectedItems.Count = 0 Then
MsgBox "No Files in Folder. Pick Another Folder"
End If

with:

    Dim FSO As Object
    Dim FDfolder As FileDialog
    Dim strFolder As String, strFile As String
    Dim wbkSource As Workbook
    Dim wbkTarget As Workbook
    Dim ws As Worksheet
       
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    ' Folder Picker
    
    Set FDfolder = Application.FileDialog(msoFileDialogFolderPicker)
    
    With FDfolder
        Do
            .Title = "Select Folder"
            .AllowMultiSelect = False
            If Not .Show Then
                MsgBox "User cancelled"
                Exit Sub
            ElseIf FSO.GetFolder(.SelectedItems(1)).Files.Count = 0 Then
                MsgBox "No Files in Folder. Pick Another Folder"
            End If
        Loop While FSO.GetFolder(.SelectedItems(1)).Files.Count = 0
        strFolder = .SelectedItems(1) & "\"
    End With

 

[SteveD01]

Thanks John. The folder select now works fine. What I have noticed though is that my select "Report" sheet (Code below) needs to be select "Report" OR "Template" as I have found a workbook that does not have a sheet named "Report". The code could be either a OR statement or it could rename any Worksheet named "Template" to "Report" - Not sure which is best ?

Set wbkSource = Workbooks.Open(Filename:=strFolder & strFile, ReadOnly:=True)
wbkSource.Worksheets("Report").Copy After:=wbkTarget.Worksheets(1)
wbkSource.Close savechanges:=False
strFile = Dir

 

[John_w]

Since the code is opening the workbook read only, it's better to choose either the "Report" or the "Template" sheet.

Replace the above snippet with:

        Set wbkSource = Workbooks.Open(Filename:=strFolder & strFile, ReadOnly:=True)
        Set ws = Nothing
        On Error Resume Next
        Set ws = wbkSource.Worksheets("Report")
        On Error GoTo 0
        If ws Is Nothing Then Set ws = wbkSource.Worksheets("Template")
        ws.Copy After:=wbkTarget.Worksheets(1)
        wbkSource.Close SaveChanges:=False
        strFile = Dir

 

[SteveD01]

Since the code is opening the workbook read only, it's better to choose either the "Report" or the "Template" sheet.

Thanks John, awesome work. Thankyou very much...I'll be back for other answers later