VBA code Error in creating too many worksheets

Question

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

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
                countSheets = countSheets + 1
                wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
            Next

            wbkSrcBook.Close SaveChanges:=False

        Next

        Dim NowTic As Long
        Dim EndToc As Long

        EndToc = (10 * 1000)

        Do
            NowTic = NowTic + 1
            DoEvents
        Loop Until NowTic >= EndToc

        If Sheets.Count = 2 Then
            Sheets(1).Name = "EL"
            Sheets(2).Name = "WL"
        ElseIf Sheets.Count = 3 Then
            Sheets(1).Name = "EL"
            If InStr(1, fnameList(1), "_FM_") > 0 Then
                Sheets(2).Name = "FM"
            ElseIf InStr(1, fnameList(1), "_NL_") > 0 Then
                Sheets(2).Name = "NL"
            End If
            Sheets(3).Name = "WL"
        ElseIf Sheets.Count = 4 Then
            Sheets(1).Name = "EL"
            Sheets(2).Name = "FM"
            Sheets(3).Name = "NL"
            Sheets(4).Name = "WL"
        End If

        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

My code keeps producing more worksheets than needed. How do I get it to stop? It only does it when I try to have 3 workbooks total. I've tried adding a TicToc to the code as you can see above but that hasn't helped. I don't know what else to try.

https://i.sstatic.net/8AvkL.png

Answer 1

Of course there are many ways of doing what you want.

This is one way: If you want to consider four files at a time for consolidation into one sheet, I would create a master file that contains that code, such as “MergeFilesMaster.xlsm.” Said file would have a sheet which you can name “Control” where you can put a button to activate the code contained in that .xlsm file. Given that your process only contemplates renaming four sheets, I assume you only want to merge four files at a time into a new workbook. The code would thus be:

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

    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
            n = wbkCurBook.Name

            For Each fnameCurFile In fnameList
                countFiles = countFiles + 1

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

                For Each wksCurSheet In wbkSrcBook.Sheets
                    countSheets = countSheets + 1
                    Select Case countSheets
                        Case 1
                            wksCurSheet.Name = "EL"
                        Case 2
                            wksCurSheet.Name = "WL"
                        Case 3
                            wksCurSheet.Name = "FM"
                        Case 4
                            wksCurSheet.Name = "NL"
                    End Select
                    wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
                Next

                wbkSrcBook.Close SaveChanges:=False
                ' because SaveChanges is set to False, the new names in the original files will not be saved.

            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

    wbkCurBook.Sheets("Control").Delete
    ' delete the empty sheet

    wbkCurBook.SaveAs Filename:= _
            "C:[your directory here]\MergeFilesMaster.xlsx" _
            , FileFormat:=xlOpenXMLWorkbook

    ' this will save your MergeFilesMaster.xlsm into an .xlsx file
    ' or add a line to change the file name, such as YYMMDD.xlsx so you can sort them by the date you processed it.

End Sub

Let me know if this worked.