VBA - Combine worksheets from multiple workbooks

[rachel06]

Hi!

I'm trying to tweak an old macro I have to use for a new process.

Basically, I have several client reports which each have a "Summary" sheet in them. I'd like this macro to combine all of the summary sheets into one workbook (where the macro will be run from) and name them "Payee ID", " ", "Summary". The payee ID is found in cell B11 of each summary sheet. I know it's not set up at all like that but it's still based on the old one and I haven't been able to get it right.

So in the code below, the "C4" value is where the path to all the files is pasted. Right now when I run the macro, it opens a window to that path but it doesn't actually run the macro so I'm stuck.

Basically the two things I'm stumped on:

1. Getting the renaming of the sheets correct
2. Getting the macro to actually run and not just open a window to the file path.

Any suggestions? Let me know if I'm not explaining this well

Sub GatherSummaries()
Dim fd As FileDialog
Dim FilePicked As Integer, f As Integer
Dim sWb As Workbook
Dim ws As Worksheet
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.InitialFileName = ActiveSheet.Range("C4").Value
fd.AllowMultiSelect = True
FilePicked = fd.Show
Application.ScreenUpdating = False
    If FilePicked = 0 Then
        Application.ScreenUpdating = True
        Exit Sub
    Else
        For f = 1 To fd.SelectedItems.Count
            Set sWb = Workbooks.Open(fd.SelectedItems(f))
                For Each ws In sWb.Worksheets
                    If ws.Name = "Summary" Then
                        ws.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
                        Sheets(Sheets.Count).Name = Left(sWb.Name, InStr(sWb.Name, " Summary") - 1)
                    End If
                Next ws
            sWb.Close False
        Next f
    End If
Application.ScreenUpdating = True

 

[John_w]

Right now when I run the macro, it opens a window to that path but it doesn't actually run the macro so I'm stuck.

Do you realise that in the file browser window you have to select the workbook(s) you want to import and click the Open button? The macro will then process the selected workbook(s).

Note - in the code below I've changed the Open button caption to "Import Summaries".

Sub GatherSummaries()

    Dim fd As FileDialog
    Dim file As Variant
    Dim sWb As Workbook
    Dim ws As Worksheet
   
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    fd.InitialFileName = ActiveSheet.Range("C4").Value
    fd.AllowMultiSelect = True
    fd.ButtonName = "Import Summaries"
    fd.Title = "Select workbooks and click Import Summaries"
    If fd.Show Then
        Application.ScreenUpdating = False
        For Each file In fd.SelectedItems
            Set sWb = Workbooks.Open(file)
            For Each ws In sWb.Worksheets
                If ws.Name = "Summary" Then
                    ws.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
                    Worksheets(Worksheets.Count).Name = ws.Range("B11").Text & " Summary"
                End If
            Next ws
            sWb.Close False
        Next
        Application.ScreenUpdating = True
    End If

End Sub

 

[rlv01]

If you want to remove the dialog and process files in the folder as defined by cell C4, then perhaps something like this.

Sub GatherSummaries()
    Dim sWb As Workbook
    Dim ws As Worksheet
    Dim FolderName As String, SheetName As String
    Dim FFolder As Object, FFile As Object

    With CreateObject("Scripting.FileSystemObject")
        FolderName = Trim(ActiveSheet.Range("C4").Value)
        
        'Test folder validity
        If Not .FolderExists(FolderName) Then
            MsgBox "The folder path in Cell C4 is invalid." & vbCr & vbCr & "'" & FolderName & "'", vbOKOnly Or vbExclamation, "Folder Path Error"
            Exit Sub
        End If

        Set FFolder = .GetFolder(FolderName)

        'Process excel files in that folder
        Application.ScreenUpdating = False
        For Each FFile In FFolder.Files
            If InStr(1, FFile.Name, ".xls", vbTextCompare) > 0 Then
                If ThisWorkbook.Name <> FFile.Name Then
                    On Error Resume Next
                    Set sWb = Nothing
                    Set sWb = Workbooks.Open(FFile.Path)
                    On Error GoTo 0
                    If Not sWb Is Nothing Then
                        For Each ws In sWb.Worksheets
                            If ws.Name = "Summary" Then
                                ws.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
                                
                                'Imported sheet name defined by cell B11
                                SheetName = ws.Range("B11").Value
                                
                                'Any sheets with the same name are overwritten
                                Application.DisplayAlerts = False
                                On Error Resume Next
                                ThisWorkbook.Worksheets(SheetName).Delete
                                On Error GoTo 0
                                Application.DisplayAlerts = True
                                
                                ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count).Name = SheetName
                            End If
                        Next ws
                        sWb.Close False
                    End If
                End If
            End If
        Next FFile
    End With

 

[alansidman]

If you wish to avoid coding then you can join workbooks with Power query

 

[rachel06]

If you wish to avoid coding then you can join workbooks with Power query

I'll have to look into this! I always forget about PQ! Thanks!!

 

[rachel06]

If you want to remove the dialog and process files in the folder as defined by cell C4, then perhaps something like this.

Sub GatherSummaries()
    Dim sWb As Workbook
    Dim ws As Worksheet
    Dim FolderName As String, SheetName As String
    Dim FFolder As Object, FFile As Object

    With CreateObject("Scripting.FileSystemObject")
        FolderName = Trim(ActiveSheet.Range("C4").Value)
       
        'Test folder validity
        If Not .FolderExists(FolderName) Then
            MsgBox "The folder path in Cell C4 is invalid." & vbCr & vbCr & "'" & FolderName & "'", vbOKOnly Or vbExclamation, "Folder Path Error"
            Exit Sub
        End If

        Set FFolder = .GetFolder(FolderName)

        'Process excel files in that folder
        Application.ScreenUpdating = False
        For Each FFile In FFolder.Files
            If InStr(1, FFile.Name, ".xls", vbTextCompare) > 0 Then
                If ThisWorkbook.Name <> FFile.Name Then
                    On Error Resume Next
                    Set sWb = Nothing
                    Set sWb = Workbooks.Open(FFile.Path)
                    On Error GoTo 0
                    If Not sWb Is Nothing Then
                        For Each ws In sWb.Worksheets
                            If ws.Name = "Summary" Then
                                ws.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
                               
                                'Imported sheet name defined by cell B11
                                SheetName = ws.Range("B11").Value
                               
                                'Any sheets with the same name are overwritten
                                Application.DisplayAlerts = False
                                On Error Resume Next
                                ThisWorkbook.Worksheets(SheetName).Delete
                                On Error GoTo 0
                                Application.DisplayAlerts = True
                               
                                ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count).Name = SheetName
                            End If
                        Next ws
                        sWb.Close False
                    End If
                End If
            End If
        Next FFile
    End With

This worked great. Thanks!!!