Const cWorksheetIWant$ = "ERR"
Const Path% = 0
Const Filename% = 1
Const SheetName% = 2
Const Address% = 3
Const ErrType% = 4
Const HasName% = 5
Const UseName% = 6
Const Formula% = 7
Const Fields$ = "IDX,Path,FileName,SheetName,Address,ErrType,HasName,UseName,Formula"
Sub ErrorMagic()
Dim strSearchFolder$, colFiles As Collection
Debug.Print "Getting Search Folder"
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Selet Folder": .AllowMultiSelect = False: .Show
If .SelectedItems.Count = 0 Then Exit Sub Else strSearchFolder = .SelectedItems(1) & "\"
End With
Set colFiles = pfGetFiles(strSearchFolder, "*.xls*")
If colFiles.Count = 0 Then Debug.Print "No Files": Set colFiles = Nothing: Exit Sub
Dim oXL As Excel.Application, strWorksheetIWant$, varFilePath, oWb As Workbook, oWs As Worksheet, colErrData As New Collection
Debug.Print "Searching Files For All Error Data"
Set oXL = New Excel.Application
oXL.Visible = False: oXL.DisplayAlerts = False
For Each varFilePath In colFiles
If pfSheetExists(varFilePath, cWorksheetIWant) Then
Set oWb = oXL.Workbooks.Open(varFilePath)
oWb.Windows(1).Visible = False
oXL.DisplayAlerts = False
psGetErrorData colErrData, oWb.Worksheets(cWorksheetIWant), oWb.Names
oWb.Close SaveChanges:=False
End If
Next varFilePath
oXL.Quit: Set oXL = Nothing
Dim ayFields, ayErrValues(), c%, r%
Debug.Print "Creating Error Data Array"
ayFields = Split(Fields, ",")
ReDim ayErrValues(0 To colErrData.Count, LBound(ayFields) To UBound(ayFields))
For c = LBound(ayFields) To UBound(ayFields)
ayErrValues(0, c) = ayFields(c)
Next c
For r = 1 To UBound(ayErrValues, 1)
ayErrValues(r, 0) = r
For c = 1 To UBound(ayFields)
ayErrValues(r, c) = colErrData(r)(c - 1)
Next c
Next r
Debug.Print "Creating Report"
Application.ScreenUpdating = False
Set oWb = Workbooks.Add: Set oWs = oWb.Worksheets(1)
With oWs.Cells(1, 1)
.Resize(colErrData.Count + 1, UBound(ayFields) - LBound(ayFields) + 1) = ayErrValues
.CurrentRegion.Rows(1).Font.Bold = True
.CurrentRegion.Columns.AutoFit
End With
Application.ScreenUpdating = True
Debug.Print "Finished"
Set colFiles = Nothing
Set oWb = Nothing
Set oWs = Nothing
Set colErrData = Nothing
End Sub
Private Function pfGetFiles(ByVal strSearch$, ByVal strExt$) As Collection
Dim cFiles As New Collection
strFound = Dir(strSearch & strExt)
Do While strFound <> ""
cFiles.Add strSearch & strFound, strFound
strFound = Dir()
Loop
Set pfGetFiles = cFiles
Set cFiles = Nothing
End Function
Private Function pfSheetExists(ByVal sFileFullPath$, ByVal sSheetName$) As Boolean
sFilePath = Left(sFileFullPath, InStrRev(sFileFullPath, "\"))
sFileName = Replace(sFileFullPath, sFilePath, "")
tmp = ExecuteExcel4Macro("'" & sFilePath & "[" & sFileName & "]" & sSheetName & "'!R1C1")
pfSheetExists = (StrComp(TypeName(tmp), "String", vbTextCompare) = 0)
End Function
Private Sub psGetErrorData(ByRef colErrData As Collection, ByVal Ws As Worksheet, ByVal colNames)
Dim rngErr As Range, element, tmp
ReDim xErr(0 To 7)
On Error Resume Next
Set rngErr = Ws.Cells.SpecialCells(xlCellTypeFormulas, 16)
On Error GoTo 0
If rngErr Is Nothing Then Exit Sub
For Each element In rngErr
xErr(Path) = Ws.Parent.FullName
xErr(Filename) = Ws.Parent.Name
xErr(SheetName) = Ws.Name
xErr(Address) = element.Address
xErr(ErrType) = element.text
xErr(Formula) = "'" & element.Formula
xErr(HasName) = False
GoSub CheckForNames
colErrData.Add xErr
Next element
Exit Sub
CheckForNames:
For Each tmp In colNames
If InStr(element.Formula, tmp.Name) > 0 Then
xErr(HasName) = True: xErr(UseName) = tmp.Name
Return
End If
Next tmp
Return
End Sub