'WHAT IS THE NAME OF THE SHEET YOU WANT TO SEARCH FOR ERRORS?
Const cWorksheetIWant$ = "Summary"
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"
'make a collection of all files to search for errors
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Selet Folder": .AllowMultiSelect = False: .Show
If .SelectedItems.Count = 0 Then Exit Sub Else strSearchFolder = .SelectedItems(1) & "\"
End With
Debug.Print vbTab & strSearchFolder
Set colFiles = pfGetFiles(strSearchFolder, "*.xls*")
If colFiles.Count = 0 Then
Debug.Print "No Files"
Set colFiles = Nothing
MsgBox "No files with " & "*.xls*" & Chr(13) & "were found in " & strSearchFolder, vbCritical + vbOKOnly
Exit Sub
End If
Debug.Print vbTab & "colFiles:" & colFiles.Count
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"
'open each XL file. Create collection of all error data using psGetErrorData sub (below)
'do this in a fresh invisible XL to speed thigs up
Set oXL = New Excel.Application
oXL.Visible = False: oXL.DisplayAlerts = False
Debug.Print vbTab & oXL.Name & " " & oXL.Workbooks.Count & " " & oXL.Windows.Count
For Each varFilePath In colFiles
If pfSheetExists(varFilePath, cWorksheetIWant) Then
Debug.Print vbTab & "pfSheetExists" & " " & cWorksheetIWant
Set oWb = oXL.Workbooks.Open(varFilePath)
oWb.Windows(1).Visible = False
oXL.DisplayAlerts = False
Debug.Print vbTab & "psGetErrorData"
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"
'put error data collection into an array for faster writing to worksheet
ayFields = Split(Fields, ",")
ReDim ayErrValues(0 To colErrData.Count, LBound(ayFields) To UBound(ayFields))
Debug.Print vbTab & "ayFields " & LBound(ayFields) & " " & 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 vbTab & "ayErrValues " & LBound(ayErrValues) & " " & UBound(ayErrValues)
'already Dim oWb and oWS above
Debug.Print "Creating Report"
'Add a new workbook and pop the Error Data onto first worksheet; format
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
'Clean Up
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
'Get all XL files in a folder and put into a collection
strFound = Dir(strSearch & strExt)
Do While strFound <> ""
cFiles.Add strSearch & strFound, strFound
strFound = Dir()
Loop
Set pfGetFiles = cFiles
Set cFiles = Nothing
End Function
'Function to get value from closed workbook
Private Function pfSheetExists(ByVal sFileFullPath$, ByVal sSheetName$) As Boolean
sFilePath = Left(sFileFullPath, InStrRev(sFileFullPath, "\"))
sFileName = Replace(sFileFullPath, sFilePath, "")
'Execute the ExecuteExcel4Macro function
tmp = ExecuteExcel4Macro("'" & sFilePath & "[" & sFileName & "]" & sSheetName & "'!R1C1")
Debug.Print vbTab & "Macro4 " & TypeName(tmp)
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)
'For the target worksheet, find all error cells and collect some data
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:
'Loop through all names and see if that name is in the error cell's formula
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
