Macro to run on multiple excel files find if any #N/A , #NAME?, #VALUE!

JAVEDR

Board Regular
Joined
Sep 17, 2019
Messages
79
Office Version
  1. 2019
Platform
  1. Windows
  2. Mobile
  3. Web
Hello Sir/Madam,

I have multiple excel files in folder contains multiple sheets. I'm looking for macro to run on those and find if any #N/A , #NAME?, #VALUE!, #REF! and provide excel name if any contains this.
 
I don't know if this is what you were looking for but I though it was an interesting problem.

The code below asks you to pick a folder. It then searches all Files/Worksheets for errors. For each cell that is an error, it collects some data: workbook path, sheetname, address, error type, if the cell's formula uses a Name, what the Name is if there is one, and the formula. It then writes that report to a worksheet in a new workbook. I am sure it could be done with a Class module or Dictionary (that might be simplier) but I wanted to do it without. I also wanted to make it easy to change which data is collected.

Open to suggestons on how to make it better.

VBA Code:
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
    
    'strSearchFolder = "C:\Users\markm\Downloads\@TEST\"
    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, 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
    
    For Each varFilePath In colFiles
    
        Set oWb = oXL.Workbooks.Open(varFilePath)
        oWb.Windows(1).Visible = False
        oXL.DisplayAlerts = False
        
        For Each oWs In oWb.Worksheets
            psGetErrorData colErrData, oWs, oWb.Names
        Next oWs

        oWb.Close SaveChanges:=False
        
    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))
    
    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
    
'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

    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
 
Upvote 0

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.
I don't know if this is what you were looking for but I though it was an interesting problem.

The code below asks you to pick a folder. It then searches all Files/Worksheets for errors. For each cell that is an error, it collects some data: workbook path, sheetname, address, error type, if the cell's formula uses a Name, what the Name is if there is one, and the formula. It then writes that report to a worksheet in a new workbook. I am sure it could be done with a Class module or Dictionary (that might be simplier) but I wanted to do it without. I also wanted to make it easy to change which data is collected.

Open to suggestons on how to make it better.

VBA Code:
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
   
    'strSearchFolder = "C:\Users\markm\Downloads\@TEST\"
    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, 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
   
    For Each varFilePath In colFiles
   
        Set oWb = oXL.Workbooks.Open(varFilePath)
        oWb.Windows(1).Visible = False
        oXL.DisplayAlerts = False
       
        For Each oWs In oWb.Worksheets
            psGetErrorData colErrData, oWs, oWb.Names
        Next oWs

        oWb.Close SaveChanges:=False
       
    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))
   
    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
   
'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

    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
Excellent sir code is more closer to what I'm looking for. Thanks a lot for your valuable time desired result giving below output can it be make shorter like workbook name , sheet name error name i.e = #REF! I don't need all error rows to be populate as it may create 1000 + entries
1670483007614.png
 
Upvote 0
I don't know if this is what you were looking for but I though it was an interesting problem.

The code below asks you to pick a folder. It then searches all Files/Worksheets for errors. For each cell that is an error, it collects some data: workbook path, sheetname, address, error type, if the cell's formula uses a Name, what the Name is if there is one, and the formula. It then writes that report to a worksheet in a new workbook. I am sure it could be done with a Class module or Dictionary (that might be simplier) but I wanted to do it without. I also wanted to make it easy to change which data is collected.

Open to suggestons on how to make it better.

VBA Code:
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
   
    'strSearchFolder = "C:\Users\markm\Downloads\@TEST\"
    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, 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
   
    For Each varFilePath In colFiles
   
        Set oWb = oXL.Workbooks.Open(varFilePath)
        oWb.Windows(1).Visible = False
        oXL.DisplayAlerts = False
       
        For Each oWs In oWb.Worksheets
            psGetErrorData colErrData, oWs, oWb.Names
        Next oWs

        oWb.Close SaveChanges:=False
       
    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))
   
    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
   
'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

    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
Not the error its formula still got captured -

1670485219812.png
 
Upvote 0
Not the error its formula still got captured -

View attachment 80419

The code that picks the cells is : Set rngErr = Ws.Cells.SpecialCells(xlCellTypeFormulas, 16)

It will pick any cell (and only cells) that evaluate to an error. There may not be an error in those formulas, but they likely refer to a cell that contains an error, so the cell's resut is an error.

For example, if cell $A$1 is =#REF! and cell $B$1 is =$A$1+1, both cells $A$1 and $B$1 will show as a #REF! error. This code will pick up both.
 
Upvote 0
Excellent sir code is more closer to what I'm looking for. Thanks a lot for your valuable time desired result giving below output can it be make shorter like workbook name , sheet name error name i.e = #REF! I don't need all error rows to be populate as it may create 1000 + entries

Easiest way is to make a Pivot Table out of the report. Or, you could delete the columns you don't want and use Remove Duplicates from the Data menu.
 
Upvote 0
Easiest way is to make a Pivot Table out of the report. Or, you could delete the columns you don't want and use Remove Duplicates from the Data menu.
Ok sir thnx a lot.
 
Upvote 0
Easiest way is to make a Pivot Table out of the report. Or, you could delete the columns you don't want and use Remove Duplicates from the Data menu.
Can I run macro only on specific sheet say Summary Sheet which is common across all multiple file rather then running on sheets.
 
Upvote 0
Can I run macro only on specific sheet say Summary Sheet which is common across all multiple file rather then running on sheets.

The code below is the same as before but it is modified to look only at the sheet you specify (Const cWorksheetIWant$ = "ERR"). It first checks to make sure that sheet exists in the workbook.


VBA Code:
'WHAT IS THE NAME OF THE SHEET YOU WANT TO SEARCH FOR ERRORS?
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"
'make a collection of all files to search for errors

    'strSearchFolder = "C:\Users\markm\Downloads\@TEST\"
    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"
'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
    
    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"
'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))

    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

'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")
        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
 
Upvote 0
The code below is the same as before but it is modified to look only at the sheet you specify (Const cWorksheetIWant$ = "ERR"). It first checks to make sure that sheet exists in the workbook.


VBA Code:
'WHAT IS THE NAME OF THE SHEET YOU WANT TO SEARCH FOR ERRORS?
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"
'make a collection of all files to search for errors

    'strSearchFolder = "C:\Users\markm\Downloads\@TEST\"
    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"
'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
   
    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"
'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))

    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

'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")
        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
"Summary" is sheet name which is constant across each files. Above code I have pasted with no result do I have to mention sheet name somewhere.
 
Upvote 0
"Summary" is sheet name which is constant across each files. Above code I have pasted with no result do I have to mention sheet name somewhere.

Yeah. Try just a little bit.

VBA Code:
'WHAT IS THE NAME OF THE SHEET YOU WANT TO SEARCH FOR ERRORS?
Const cWorksheetIWant$ = "ERR"  '<<<< PUT THE NAME OF YOUR WORKSHEET HERE.  REPLACE "ERR".  USE QUOTES.  NO SPACES IN THE WORKSHEET NAME ARE ALLOWED.
 
Upvote 0

Forum statistics

Threads
1,223,893
Messages
6,175,240
Members
452,621
Latest member
Laura_PinksBTHFT

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top