请帮助我！

Question

请帮助我！

我有一个Excel 2016的 VBA宏代码，只是不想转到下一步。我想在这里做的是

将<10 CSV文件批量插入到单独的工作表中（有效），并且;
然后关闭超时框或按OK，选择第一张工作表，然后将其删除，然后
然后将其余工作表合并为一个。

下面的代码（很抱歉，这是很长的代码），我已经突出显示了对我而言不起作用的部分。实际上，代码会在超时框后停止，并且不会继续。

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)

如何使它运行完整？

请帮助我！

1 个答案: