Как я могу заставить это работать полностью?

Question

Помогите мне, пожалуйста!

У меня есть Макрос-код VBA для Excel 2016, который просто не хочет переходить к следующему шагу. Я пытаюсь сделать следующее:

1. массовая вставка <10 CSV-файлов в отдельные листы (что работает) и </li>
2. затем, когда окно тайм-аута закрывается или вы нажимаете OKвыберите первый лист и затем удалите его;
3. затем объедините остальные листы в один.

Код приведен ниже (извините, он длинный),и я выделил раздел, который не «работает» для меня. Код фактически останавливается после тайм-аута и не будет продолжаться.

Sub Combine()
MsgBox "Please follow the following guidelines" & vbCr & "» Please make sure that all sheets are included in this workbook, and that you have clicked on cell 'A1' before continuing" & vbCr & "» Do not interrupt the process" & vbCr & "» Do not change the Macro code" & vbCr & "» Do not save over this Template." & vbCr & "   If you need to save this file, please go File » Save As.", vbOKOnly + vbExclamation, Title:="IMPORTANT INFORMATION!"
MsgBox "The Front sheet will be deleted." & vbCr & "This is to simply create one sheet file. You will not need need this after the process has completed" & vbCr & vbCr & "Please press 'OK' to continue." & vbCr & "This cannot be undone!", vbOKOnly + vbCritical
    Dim fnameList, fnameCurFile As Variant
    Dim countFiles, countSheets As Integer
    Dim wksCurSheet As Worksheet
    Dim wbkCurBook, wbkSrcBook As Workbook

    fnameList = Application.GetOpenFilename(FileFilter:="CSV; XLS; XLSX; XLSM; TEXT; (*.csv;*.xls;*.xlsx;*.xlsm;*.txt),*.csv;*.xls;*.xlsx;*.xlsm;*.txt", 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

            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic

                Dim AckTime As Integer, InfoBox As Object
                Set InfoBox = CreateObject("WScript.Shell")
                'Set the message box to close after 10 seconds
                AckTime = 5
                Select Case InfoBox.Popup("Processed" & countFiles & " files." & vbCr & "(this window closes automatically after 5 seconds).", _
                AckTime, "Excel File Merger", 0)
                    Case 1, -1
                        Exit Sub
                End Select

            Range("A1").Select

            Worksheets("Cover").Delete
            MsgBox "Cover Sheet has now been deleted. The rest of the code will continue.", vbOKOnly + vbInformation
                Dim i As Integer
                Dim xTCount As Variant
                Dim xWs As Worksheet
                On Error Resume Next
            LInput:
                xTCount = Application.InputBox("The number of title rows", "Please enter the amount of rows that are Titles or Table Headers", "1")
                If TypeName(xTCount) = "Boolean" Then Exit Sub
                If Not IsNumeric(xTCount) Then
                    MsgBox "Only can enter number", , "Error in input"
                    GoTo LInput
                End If
                Set xWs = ActiveWorkbook.Worksheets.Add(Sheets(1))
                xWs.Name = "Combined"
                Worksheets(2).Range("A1").EntireRow.Copy Destination:=xWs.Range("A1")
                For i = 2 To Worksheets.Count
                    Worksheets(i).Range("A1").CurrentRegion.Offset(CInt(xTCount), 0).Copy _
                           Destination:=xWs.Cells(xWs.UsedRange.Cells(xWs.UsedRange.Count).Row + 1, 1)
                Next
                Application.ScreenUpdating = False
                Application.DisplayAlerts = False
                For Each xWs In Application.ActiveWorkbook.Worksheets
                    If xWs.Name <> "Combined" And xWs.Name <> "Combined" Then
                        xWs.Delete
                    End If
                Next
                    ActiveSheet.ListObjects.Add(SourceType:=xlSrcRange, _
                    Source:=Selection.CurrentRegion, _
                    xlListObjectHasHeaders:=xlYes _
                    ).Name = "DataTable"
                Range("G1").Select
                    ActiveCell.FormulaR1C1 = "Treatment Strategy Stage"
                Range("A1").Select
            MsgBox "Procesed - all Sheets are now Merged and filtered." & vbCr & "Thank you for your patience", Title:="Merge Excel Sheets"
        End If
    Else
        MsgBox "No files selected", Title:="Merge Excel files"
    End If
End Sub

Любая помощь будет принята с благодарностью

Answer 1

Если я правильно понимаю, вы никогда не захотите выйти из сабвуфера, поэтому измените это

           Select Case InfoBox.Popup("Processed" & countFiles & " files." & vbCr & "(this window closes automatically after 5 seconds).", _
            AckTime, "Excel File Merger", 0)
                Case 1, -1
                    Exit Sub
            End Select

на это

           Call InfoBox.Popup("Processed" & countFiles & " files." & vbCr & _
           "(this window closes automatically after 5 seconds).", _
           AckTime, "Excel File Merger", 0)