Sub ImportFiles() Dim wbNew As Workbook, strPath As String, xWS As Worksheet, xMWS As Worksheet, xTWB As Workbook
Dim xStrAWBName As String, Sh1 As Worksheet, FolderName As String, R As Long, Lr1 As Long
Dim FolderPath As String, fldr As FileDialog, sItem As String, FileName As String, Lr2 As Long
Dim LC As Long
On Error Resume Next
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
FolderName = sItem
Set fldr = Nothing
FolderPath = FolderName & "\"
Set xTWB = ThisWorkbook
Set Sh1 = xTWB.Sheets("Sheet1")
Set Sh2 = xTWB.Sheets("Sheet2")
LC = 1
FileName = Dir(FolderPath & "*.xls*")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Do While FileName <> ""
Workbooks.Open
FileName:=FolderPath & FileName, ReadOnly:=True
xStrAWBName = ActiveWorkbook.Name
For Each xWS In ActiveWorkbook.Sheets
R = Application.WorksheetFunction.CountA(xWS.Range("A1:Z200"))
If R > 0 Then
Lr1 = xWS.Range("A" & Rows.Count).End(xlUp).Row
LC = LC + 1
Lr2 = xTWB.Sh1.Range("A" & Rows.Count).End(xlUp).Row
If LC = 2 Then
xWS.Range(Cells(1, 1), Cells(Lr1, 1)).Copy xTWB.Sh1.Range("A1" )
xWS.Range(Cells(1, 1), Cells(Lr1, 1)).Copy xTWB.Sh2.Range("A1" )
End if
xWS.Range(Cells(1, 2), Cells(Lr1, 2)).Copy xTWB.Sh1.Cells(1, LC)
xWS.Range(Cells(1, 3), Cells(Lr1, 3)).Copy xTWB.Sh2.Cells(1, LC)
End If
Next xWS
Workbooks(xStrAWBName).Close
FileName = Dir()
Loop
xTWB.SaveAs
FileName:="D:\Consolidation", FileFormat:=xlWorkbookNormal Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub