Option Explicit
Sub Run_Update()
Dim mainReport As Workbook
Dim arrEmp() As Variant
Dim oFile As String
Dim sErrMSB As String
Dim finalRow As Long
Dim i As Long
Dim n As Long
Application.ScreenUpdating = False 'Turn off screen updating to speed up macro
ReDim arrEmp(4, 0)
ChDrive "P:"
ChDir "[COLOR=#333333]P:\Coaching\Schemes - Denah[/COLOR]"
'Change this line to the directory that contains the workbooks
oFile = Dir("[COLOR=#333333]P:\Coaching\Schemes - Denah[/COLOR]\*.xlsm")
'Load workbook object of Overview workbook into variable
Set mainReport = Application.Workbooks("Team Overview.xlsm")
'Find the last used row in column B and load to variable
finalRow = Cells(Rows.Count, 2).End(xlUp).Row
'Delete the old data in the Overview workbook
If finalRow > 7 Then Range("B8:J" & finalRow).Value = ""
'Start Looping through all files in the directory
Do While oFile <> ""
On Error GoTo Trap
If Right(oFile, Len(mainReport.Name)) <> mainReport.Name Then
Workbooks.Open Filename:=oFile, UpdateLinks:=False, ReadOnly:=True 'Open file
finalRow = Workbooks(oFile).Sheets("Feedback Log").Cells(Rows.Count, 2).End(xlUp).Row 'Find last row in column B
If finalRow > 7 Then
If Not arrEmp(0, 0) = "" Then
ReDim Preserve arrEmp(4, UBound(arrEmp, 2) + finalRow - 7) 'Expand 2nd dimension of the array to hold the new data
End If
For i = 8 To finalRow 'Loop through the rows
arrEmp(0, n) = Left(Workbooks(oFile).Name, Len(Workbooks(oFile).Name) - 5) 'Load workbook name
arrEmp(1, n) = Workbooks(oFile).Sheets("Feedback Log").Range("B" & i).Value 'Load column B data in the row to array
arrEmp(2, n) = Workbooks(oFile).Sheets("Feedback Log").Range("D" & i).Value 'Load column D data in the row to array
arrEmp(3, n) = Workbooks(oFile).Sheets("Feedback Log").Range("F" & i).Value 'Load column F data in the row to array
arrEmp(4, n) = Workbooks(oFile).Sheets("Feedback Log").Range("H" & i).Value 'Load column H data in the row to array
If Err.Number = 0 Then n = n + 1 Else Err.Clear 'Increase the 2nd dimension counter for next row
Next i 'Loop to next row/exit if no more rows
End If
Workbooks(oFile).Close SaveChanges:=False 'Close the employee workbook
End If
Skip:
oFile = Dir
Loop
On Error GoTo 0
Application.ScreenUpdating = True 'Turn screen updating back on to see values being added to overview workbook
n = 8 'Turn counter into row marker
For i = LBound(arrEmp, 2) To UBound(arrEmp, 2) 'Loop through the array and unload the data to the Overview workbook row by row
Cells(n, 2).Value = arrEmp(0, i)
Cells(n, 4).Value = arrEmp(1, i)
Cells(n, 6).Value = arrEmp(2, i)
Cells(n, 8).Value = arrEmp(3, i)
Cells(n, 10).Value = arrEmp(4, i)
n = n + 1
Next i
If sErrMSB <> "" Then
MsgBox "The following workbooks were not imported:" & vbCr & vbCr & sErrMSB & vbCr & "You'll need to add the Feedback manually to complete the compilation."
Else
MsgBox "All Feedback data has successfully been compiled."
End If
Exit Sub
Trap:
If Err.Number = 9 Then
Resume Next
ElseIf Err.Number = 1004 Then
sErrMSB = sErrMSB & oFile & vbCr
GoTo Skip
Else
On Error GoTo 0
Application.ScreenUpdating = True
Resume
End If
End Sub
