Help with VBA code to copy from miltiple sheets to a master sheet

[Ksp3cialK]

Hello, I'm pretty new to this. Currently I have multiple Excel files with multiple sheets in them. To put simply, they are visual representations of BOM's for various machines. I currently place a copy in a folder and make a new sheet in that file for missing parts. In an effort to streamline parts ordering, I want to automate this process as much as I can. At the moment I open and close every sheet to check parts needed which gets a little tedious.

My end goal is to copy only the missing parts sheets to a master sheet to have everything needed in one place.

This is what I have hobbled together so far, it successfully copies the specific sheets I want into a master sheet. I can't seem to figure out how to rename the missing parts sheets to the original file name the missing parts sheet was pulled from.

Also is there any way I can run the macro and it update the sheet instead of making new sheets or check if a sheet is already there and only add new missing parts sheets if they are not in the master? Hopefully this is explained well enough.

Sub MergeExcelFiles()
Dim fnameList, fnameCurFile As Variant
Dim countFiles, countSheets As Integer
Dim wksCurSheet As Worksheet
Dim wbkCurBook, wbkSrcBook As Workbook

fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)

If (vbBoolean <> VarType(fnameList)) Then

If (UBound(fnameList) > 0) Then
countFiles = 0
countSheets = 0

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set wbkCurBook = ActiveWorkbook

For Each fnameCurFile In fnameList
countFiles = countFiles + 1

Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)

For Each wksCurSheet In wbkSrcBook.Sheets
'last sheet got an index equal to countSheets.
'the sheet before the last one will be then countSheets-1
If wksCurSheet.Name = "Missing Parts" Or wksCurSheet.Name = "Build 1 Missing Parts" Or wksCurSheet.Name = "Build 2 Missing Parts" Then wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
Next
wbkSrcBook.Close SaveChanges:=False
Next

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
End If

Else
MsgBox "No files selected", Title:="Merge Excel files"
End If
End Sub

 

[JLGWhiz]

This is how it would look with your code as it is currently written:
If wksCurSheet.Name = "Missing Parts" Or wksCurSheet.Name = "Build 1 Missing Parts" Or wksCurSheet.Name = "Build 2 Missing Parts" Then
wksCurSheet.Copy after:=wbkCurbook.Sheets(wbkCurbook.Sheets.Count)
wbkCurbook.Sheets(wbkCurbook.Sheets.Count).Name = Left(fnameCurFile.Name, Len(fnameCurFile.Name) - InStr(fnameCurFile.Name, "."))
Next
wbkSrcBook.Close SaveChanges:=False
Next

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
End If

I suggest you move the 'End If' Sot that it looks like this

    If wksCurSheet.Name = "Missing Parts" Or wksCurSheet.Name = "Build 1 Missing Parts" Or wksCurSheet.Name = "Build 2 Missing Parts" Then
        wksCurSheet.Copy after:=wbkCurbook.Sheets(wbkCurbook.Sheets.Count)
        wbkCurbook.Sheets(wbkCurbook.Sheets.Count).Name = Left(fnameCurFile.Name, Len(fnameCurFile.Name) - InStr(fnameCurFile.Name, "."))
    End If
Next
wbkSrcBook.Close SaveChanges:=False
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"

 

[Ksp3cialK]

Thank you for your help! I edited the code and I'm getting an "Block If without End If" error, any ideas? I've tried a few things and googled around, but I guess I don't quite understand.

Sub MergeExcelFiles()
Dim fnameList, fnameCurFile As Variant
Dim countFiles, countSheets As Integer
Dim wksCurSheet As Worksheet
Dim wbkCurBook, wbkSrcBook As Workbook
fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)
If (vbBoolean <> VarType(fnameList)) Then
If (UBound(fnameList) > 0) Then
countFiles = 0
countSheets = 0
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set wbkCurBook = ActiveWorkbook
For Each fnameCurFile In fnameList
countFiles = countFiles + 1
Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
For Each wksCurSheet In wbkSrcBook.Sheets
'last sheet got an index equal to countSheets.
'the sheet before the last one will be then countSheets-1
If wksCurSheet.Name = "Missing Parts" Or wksCurSheet.Name = "Build 1 Missing Parts" Or wksCurSheet.Name = "Build 2 Missing Parts" Then
wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
wbkCurBook.Sheets(wbkCurBook.Sheets.Count).Name = Left(fnameCurFile.Name, Len(fnameCurFile.Name) - InStr(fnameCurFile.Name, "."))
End If
Next
wbkSrcBook.Close SaveChanges:=False
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
Else
MsgBox "No files selected", Title:="Merge Excel files"
End If
End Sub

 

[JLGWhiz]

Try this:

Sub MergeExcelFiles()
Dim fnameList, fnameCurFile As Variant
Dim countFiles, countSheets As Integer
Dim wksCurSheet As Worksheet
Dim wbkCurBook, wbkSrcBook As Workbook
fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)
    If (vbBoolean <> VarType(fnameList)) Then
        If (UBound(fnameList) > 0) Then
            countFiles = 0
            countSheets = 0
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
            Set wbkCurBook = ActiveWorkbook
            For Each fnameCurFile In fnameList
                countFiles = countFiles + 1
                Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
                For Each wksCurSheet In wbkSrcBook.Sheets
                'last sheet got an index equal to countSheets.
                'the sheet before the last one will be then countSheets-1
                    If wksCurSheet.Name = "Missing Parts" Or wksCurSheet.Name = "Build 1 Missing Parts" _
                    Or wksCurSheet.Name = "Build 2 Missing Parts" Then
                        wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
                        wbkCurBook.Sheets(wbkCurBook.Sheets.Count).Name = Left(fnameCurFile.Name, _
                        Len(fnameCurFile.Name) - InStr(fnameCurFile.Name, "."))
                    End If
                Next
                wbkSrcBook.Close SaveChanges:=False
            Next
            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic
            MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
        Else
            MsgBox "No files selected", Title:="Merge Excel files"
        End If
    End If
End Sub

Using the indent method in your code helps to edit for block if and loop statements to make sure they are all closed end. I should have caught that when I changed your statement inside the inner loop. Sorry about that.

 

[Ksp3cialK]

Thank you very for your help, the indented code is much easier to read. Unfortunately it errored out, it opened the first sheet and didn't close it thus stopping the whole program.

Side note, I have been playing around and have it working almost as good as I want. At least my initial requirements are met. How hard would it be to have this workbook update the original sheet it copied from, also how hard would it be to run the macro and have it update the sheet if it already exist instead of making new sheets. Currently I have to delete them and rerun the code.

Current working code I hobbled together from the internet tweaked with trial and error.

Sub MergeExcelFiles()
    Dim fnameList, fnameCurFile As Variant
    Dim countFiles, countSheets As Integer
    Dim wksCurSheet As Worksheet
    Dim wbkCurBook, wbkSrcBook As Workbook
 
    fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)
 
    If (vbBoolean <> VarType(fnameList)) Then
 
        If (UBound(fnameList) > 0) Then
            countFiles = 0
            countSheets = 0
 
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
 
            Set wbkCurBook = ActiveWorkbook
 
            For Each fnameCurFile In fnameList
                countFiles = countFiles + 1
 
                Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
 
    For Each wksCurSheet In wbkSrcBook.Sheets
                'last sheet got an index equal to countSheets.
                'the sheet before the last one will be then countSheets-1
                If wksCurSheet.Name = "Missing Parts" Or wksCurSheet.Name = "Build 1 Missing Parts" Or wksCurSheet.Name = "Build 2 Missing Parts" Then wksCurSheet.Copy After:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
            Next
            wbkSrcBook.Close SaveChanges:=False
        Next
            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic
            Call RenameTabs
            Call ListSheets
 
            MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
        End If
 
    Else
        MsgBox "No files selected", Title:="Merge Excel files"
    End If
End Sub

Sub RenameTabs()
'Updateby20140624
 For x = 1 To Sheets.Count
 If Worksheets(x).Range("A1").Value <> "" Then
 Sheets(x).Name = Worksheets(x).Range("A1").Value
 End If
 Next
 End Sub

Sub ListSheets()
   Dim w As Worksheet
   Dim i As Integer
   i = 2
   Sheets("Sheet List").Range("A:A").Clear
   For Each w In Worksheets
       Sheets("Sheet List").Cells(i, 1) = w.Name
       i = i + 1
   Next w
End Sub

 

[JLGWhiz]

I did not test the code because I did not want to bother with creating a test set up that matched your workbook and sheet names, so I left the testing to you. When reporting errors on the forum you should specify the error message and the line of code indicated by highlight when you click the 'Debug' button. That tells the responders where and what to look for to remedy the problem.

The issue of the workbook not closing is due to the location of the 'Workbook.Close' statement. If it is located in the wrong place between 'If...Then' statements, it could be jumped over because the 'If ...then' statement equated to False and jumped to the 'End If' for that statement. So read the code and see where the close statement best fits for what you want to happen. I usually put mine right after the lines of code that do all the tasks related to that workbook.

The parf about updating the sheets and workbooks are beyond the scope of the original post and should be addressed in a new thread per forum guidelines. But if you do create a new thread you should not use vague terms like "Update" because it gives no definition of what needs to be done. State what changes need to be done to make the updates.

Glad you got it working,
Regards, JLG