Option Explicit
Sub test()
Dim LastRow As Double, sht As Worksheet, FSO As Object
Dim FlDr As Object, FileNm As Object, Cnt As Integer, Cnt2 As Integer, Cnt3 As Integer, Cnt4 As Integer
Dim RngArr() As Variant, RngArr2() As Variant, Rng As Range, Rng2 As Range
On Error GoTo Erfix
Application.Cursor = xlWait
ThisWorkbook.Sheets("TAB1").Range("D4:AJ1000").ClearContents
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Cnt2 = 1 'dimension array
Cnt3 = 0 'array positions
Set FSO = CreateObject("scripting.filesystemobject")
'***change Folder path/name to your folder path/name
Set FlDr = FSO.GetFolder("I:\Accounts\2018\Financial Reporting\BRD\NewRev\Files")
For Each FileNm In FlDr.Files
If FileNm.Name Like "*.xlsm" Then
Workbooks.Open Filename:=FileNm
For Each sht In Workbooks(FileNm.Name).Sheets
If sht.Name = "CC" Then
Cnt2 = Cnt2 + 1
ReDim Preserve RngArr(Cnt2)
ReDim Preserve RngArr2(Cnt2)
With Workbooks(FileNm.Name).Sheets(sht.Name)
Set Rng = .Range(.Cells(25, "E"), .Cells(25, "AK"))
Set Rng2 = .Range(.Cells(40, "E"), .Cells(40, "AK"))
End With
RngArr(Cnt3) = Rng
RngArr2(Cnt3) = Rng2
Cnt3 = Cnt3 + 1
Exit For
End If
Next sht
Workbooks(FileNm.Name).Close SaveChanges:=False
End If
Next FileNm
Cnt = 4
For Cnt4 = 0 To Cnt3 - 1
With ThisWorkbook.Sheets("TAB1")
.Range(.Cells(Cnt, "D"), .Cells(Cnt, "AJ")) = RngArr(Cnt4)
.Range(.Cells(Cnt + 1, "D"), .Cells(Cnt + 1, "AJ")) = RngArr2(Cnt4)
End With
Cnt = Cnt + 2
Next Cnt4
MsgBox "Finished Files"
LastRow = Sheets("TAB1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Sheets("TAB1").Sort.SortFields.Clear
Sheets("TAB1").Sort.SortFields.Add Key:=Range("D5:D" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Sheets("TAB1").Sort
.SetRange Range("D5:AJ" & LastRow)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Application.Cursor = xlDefault
Set FlDr = Nothing
Set FSO = Nothing
Exit Sub
Erfix:
On Error GoTo 0
MsgBox "Error"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Application.Cursor = xlDefault
Set FlDr = Nothing
Set FSO = Nothing
End Sub
