I have a VBA Macro Code for Excel 2016 that just does not want to go to the next step. What I am trying to do here is
- bulk insert <10 CSV files into Separate Sheets (which does work) and;
- then once the time out box closes or you press OK, select the first sheet and then delete it, and;
- then merge the rest of the sheets into one.
The code is below (sorry it is a long one), and I have highlighted the section that is not 'working' for me. The code in fact stops after the time out box, and will not continue.
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
