Sub ImportFiles()
'declare Active tWB and Merge tab
Dim tWB As Workbook: Set tWB = ThisWorkbook
'this will be the name for your merge sheet change
'"Merge" to whatever you'd like the sheet to be
Dim mrg As String: mrg = "Merge"
'checks if mrg sheet exists, will delete if true
If WSExists(mrg) Then
'Merge exists, so delete it
Application.DisplayAlerts = False
tWB.Sheets("Merge").Delete
Application.DisplayAlerts = True
End If
'creates new Merge sheet
Dim tWS As Worksheet: Set tWS = tWB.Sheets.Add(After:=tWB.Worksheets(tWB.Worksheets.Count))
tWS.Name = mrg
'declares folder picker as a variable
Dim fldPick As FileDialog: Set fldPick = Application.FileDialog(msoFileDialogFolderPicker)
With fldPick
.AllowMultiSelect = False
.Title = "Select the File Folder"
.Show
If .SelectedItems.Count = 0 Then Exit Sub
End With
'Optimize processing
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
On Error GoTo ResetSettings
'set up loop through iPath to select all Excel files
Dim iFolder As String: iFolder = fldPick.SelectedItems(1) & "\"
Dim iExt As String: iExt = "*.xls*"
Dim iFile As String: iFile = Dir(iFolder & iExt)
Dim xWB As Workbook, xLRow As Long, xLCol As Integer, tLRow As Long
Dim cnt As Integer: cnt = 0
'loop through each excel file in iPath
Do While iFile <> ""
Set xWB = Workbooks.Open(FileName:=iFolder & iFile, ReadOnly:=True)
DoEvents
With xWB.Sheets(1)
If tWS.Cells(tWS.Rows.Count, 1).End(xlUp).Row = 1 Then
'merge sheet is blank, so copy header row with first import sheet
.Cells(1, 1).CurrentRegion.Copy
'if there are formulas to retain, then use xlPasteFormulasAndNumberFormats
tWS.Cells(1, 1).PasteSpecial xlPasteValuesAndNumberFormats
Else
'merge sheet is not blank (thus, has header row already), so copy
'only the import file's data without header row
'determines last row and column of import sheet
xLRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
xLCol = .Cells(1, .Cells.Columns.Count).End(xlToLeft).Column
'determines last row of merge sheet
tLRow = tWS.Cells(tWS.Rows.Count, 1).End(xlUp).Row
'copies and pastes data
.Range(.Cells(2, 1), .Cells(xLRow, xLCol)).Copy
'if there are formulas to retain, then use xlPasteFormulasAndNumberFormats
tWS.Cells(tLRow + 1, 1).PasteSpecial xlPasteValuesAndNumberFormats
End If
'count used in task completion message
cnt = cnt + 1
End With
DoEvents
'turn off alerts for clipboard message before xWB.close
Application.DisplayAlerts = False
xWB.Close savechanges:=False
Application.DisplayAlerts = True
iFile = Dir
Loop
'Restores settings
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
'Task completion message
MsgBox "There were " & cnt & " files successfully imported to the merge sheet." _
, vbInformation + vbOKOnly, "Files Imported"
Exit Sub
'Error Handling
ResetSettings:
MsgBox "The below error has occurred: " & vbCrLf & vbCrLf & "Error Number:" & Err.Number & vbCrLf & _
"Error Description: " & Err.Description
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Function WSExists(SheetName As String) As Boolean
Dim TempSheetName As String
TempSheetName = UCase(SheetName)
WSExists = False
For Each Sheet In Worksheets
If TempSheetName = UCase(Sheet.Name) Then
WSExists = True
Exit Function
End If
Next Sheet
End Function