I decided to create a script that would search a workbook for formulas that contain a certain word or just all formulas due to This thread.
The following code will ask for a workbook to look for formulas in each worksheet of the workbook.
After opening the workbook selected, it will search all worksheets for formulas & if formulas are found in a worksheet, it will produce 2 worksheets. One sheet will be the summary of the sheets that contain formulas, the ranges of formulas on those sheets, & the # of formulas found on those sheets, the other sheet will display every single formula found, sheet that it was found in, & the cell address of the sheet that it was found in.
Please let me know what you think.
Likes/Dislikes?
Anyway to improve the results?
Please post what system you test it on also.
The following code will ask for a workbook to look for formulas in each worksheet of the workbook.
After opening the workbook selected, it will search all worksheets for formulas & if formulas are found in a worksheet, it will produce 2 worksheets. One sheet will be the summary of the sheets that contain formulas, the ranges of formulas on those sheets, & the # of formulas found on those sheets, the other sheet will display every single formula found, sheet that it was found in, & the cell address of the sheet that it was found in.
VBA Code:
Sub FindFormulas()
'
Dim StartTime As Double
Dim ArrayRow As Long
Dim SheetFormulaCount As Long, SheetsWithFormulasCount As Long
Dim cel As Range, FormulaSearchRange As Range
Dim FileToCheck As String
Dim SearchWord As String
Dim SheetWithSearchedFormulas As String, SummarySheetOfAllFormulasFound As String
Dim HeaderTitlesToPaste As Variant
Dim SheetNameAndAllFormulasRangeArray As Variant, TempArray As Variant
Dim wsDestination_1 As Worksheet, wsDestination_2 As Worksheet
Dim wSheet As Worksheet
'
SheetWithSearchedFormulas = "Found Formulas" ' <--- Set this to the name of the sheet that you want the found formulas to be displayed
SummarySheetOfAllFormulasFound = "Summary" ' <--- Set this to the name of the sheet that you want the summary of all formulas
' ' found to be displayed
'
' \/ \/ \/ \/ \/ \/
SearchWord = "=" ' <--- Set this to what type of formula you want to find ... "=" will find all formulas
' ' Another Example: SearchWord = "Round" will find formulas that contain "Round"
Application.ScreenUpdating = False ' Turn off ScreenUpdating
'
FileToCheck = Application.GetOpenFilename() ' Ask user for the file to check formulas in
If FileToCheck = "False" Then Exit Sub ' If user cancelled then Exit Sub
'
Workbooks.Open (FileToCheck) ' Open the file selected by the user
'
FileToCheck = Mid(FileToCheck, InStrRev(FileToCheck, "\") + 1) ' Save just the filename & extension after last '\' in string to FileToCheck
'
'---------------------------------------------------------------------------------------------------
'
StartTime = Timer ' Start the stopwatch
'
HeaderTitlesToPaste = Array("Formula Found", "Sheet Name Containing Formula", "Cell Address") ' Header to write to wsDestination_1
'
On Error Resume Next ' If error occurs because the sheet doesn't exist, skip error & continue
Set wsDestination_1 = ThisWorkbook.Sheets(SheetWithSearchedFormulas) ' Check if the chosen sheet name to put the results into already exists
Set wsDestination_2 = ThisWorkbook.Sheets(SummarySheetOfAllFormulasFound) ' Check if the chosen sheet name to put the results into already exists
On Error GoTo 0 ' Return error handling back to Excel
'
If Not wsDestination_1 Is Nothing Then ' If chosen sheet name already exists then ...
wsDestination_1.UsedRange.ClearContents ' Clear the previous results on the sheet
Else ' Else ...
ThisWorkbook.Sheets.Add(Before:=Sheets(1)).Name = SheetWithSearchedFormulas ' Create the destination sheet at the beginning of the workbook
Set wsDestination_1 = ThisWorkbook.Sheets(SheetWithSearchedFormulas) ' Assign the chosen sheet name to put the results into to wsDestination_1
End If
'
If Not wsDestination_2 Is Nothing Then ' If chosen sheet name already exists then ...
wsDestination_2.UsedRange.ClearContents ' Clear the previous results on the sheet
Else ' Else ...
ThisWorkbook.Sheets.Add(Before:=Sheets(1)).Name = SummarySheetOfAllFormulasFound ' Create the destination sheet at the beginning of the workbook
Set wsDestination_2 = ThisWorkbook.Sheets(SummarySheetOfAllFormulasFound) ' Assign the chosen sheet name to put the results into to wsDestination_2
End If
'
wsDestination_1.Range("A1:C1").Value = HeaderTitlesToPaste ' Copy some headers to wsDestination_1
'
'---------------------------------------------------------------------------------------------------
'
'
ReDim TempArray(1 To Rows.Count - 1, 1 To 3) ' Establish TempArray row size & column count
ReDim SheetNameAndAllFormulasRangeArray(1 To 500, 1 To 3) ' Establish SheetNameAndAllFormulasRangeArray to handle up to 500 sheets, we can adjust this
' ' to a smaller actual # needed later
ArrayRow = 0 ' Initialize ArrayRow
SheetsWithFormulasCount = 0 ' Initialize SheetsWithFormulasCount
'
For Each wSheet In ActiveWorkbook.Worksheets ' Loop through each sheet in the workbook
If wSheet.Name <> SheetWithSearchedFormulas Then ' If sheet name <> to the name of our SheetWithSearchedFormulas then ...
On Error Resume Next ' If there are no formulas found on the sheet, skip error that would occur on the next line
Set FormulaSearchRange = wSheet.UsedRange.SpecialCells(xlCellTypeFormulas) ' Set FormulaSearchRange to the range of formulas detected
On Error GoTo 0 ' Return error handling back to excel
'
If Not FormulaSearchRange Is Nothing Then ' If we found at least one formula on the sheet then ...
SheetsWithFormulasCount = SheetsWithFormulasCount + 1 ' Increment SheetsWithFormulasCount
'
SheetFormulaCount = Range(FormulaSearchRange.Address(0, 0)).Cells.Count ' Count the total # of formulas found on the sheet
'
SheetNameAndAllFormulasRangeArray(SheetsWithFormulasCount, 1) = wSheet.Name ' Save the sheet name to SheetNameAndAllFormulasRangeArray
SheetNameAndAllFormulasRangeArray(SheetsWithFormulasCount, 2) = _
FormulaSearchRange.Address(0, 0) ' Save the formula ranges found to SheetNameAndAllFormulasRangeArray
SheetNameAndAllFormulasRangeArray(SheetsWithFormulasCount, 3) = SheetFormulaCount ' Save the total # of formulas found on the sheet to SheetNameAndAllFormulasRangeArray
'
For Each cel In FormulaSearchRange ' Loop through each cell that contains a formula
If InStr(1, cel.Formula, SearchWord, vbTextCompare) > 0 Then ' If SearchWord is found in the found formula then ...
ArrayRow = ArrayRow + 1 ' Increment ArrayRow
'
TempArray(ArrayRow, 1) = Mid(cel.Formula, 2, (Len(cel.Formula))) ' Save the formula minus the '=' sign into column A of TempArray
TempArray(ArrayRow, 2) = wSheet.Name ' Save the sheet name into column B of TempArray
TempArray(ArrayRow, 3) = cel.Address(0, 0) ' Save the cell address into column C of TempArray
End If
'
If ArrayRow = UBound(TempArray, 1) Then ' If the TempArray is full then ...
wsDestination_1.Range("A2").Resize(UBound(TempArray, 1), _
UBound(TempArray, 2)) = TempArray ' Write the TempArray to wsDestination_1
'
wsDestination_1.Columns("A").Resize(, 5).EntireColumn.Insert ' Insert 5 columns to the beginning of wsDestination_1
wsDestination_1.Range("A1:C1").Value = HeaderTitlesToPaste ' Copy some headers to wsDestination_1
'
ArrayRow = 0 ' Reset Arrayrow
ReDim TempArray(1 To Rows.Count - 1, 1 To 3) ' Clear TempArray
End If
Next ' Loop back
End If
End If
'
DoEvents ' Allow Break in the program if desired
Next ' Loop back
'
Workbooks(FileToCheck).Close SaveChanges:=False ' Close the file that was opened without saving it
'
'---------------------------------------------------------------------------------------------------
'
TempArray = ReDimPreserve(TempArray, ArrayRow, 3) ' Correct the row size of TempArray to actual # of used rows
SheetNameAndAllFormulasRangeArray = ReDimPreserve(SheetNameAndAllFormulasRangeArray, _
SheetsWithFormulasCount, 3) ' Correct the row size of SheetNameAndAllFormulasRangeArray to actual # of used rows
'
wsDestination_1.Range("A2").Resize(UBound(TempArray, 1), UBound(TempArray, 2)) = TempArray ' Write the TempArray to wsDestination_1
wsDestination_1.UsedRange.EntireColumn.AutoFit ' Autofit the data
'
Application.Goto wsDestination_1.Range("A2") ' Select A2 on wsDestination_1
ActiveWindow.FreezePanes = True ' Freeze row 1
'
wsDestination_2.Range("A1:C1").Value = Array("Sheet Name", "Formula Ranges", "# of Formulas") ' Copy some headers to wsDestination_2
wsDestination_2.Range("A2").Resize(UBound(SheetNameAndAllFormulasRangeArray, 1), _
UBound(SheetNameAndAllFormulasRangeArray, 2)) = SheetNameAndAllFormulasRangeArray ' Write the SheetNameAndAllFormulasRangeArray to wsDestination_2
wsDestination_2.UsedRange.EntireColumn.AutoFit ' Autofit the data
'
Application.Goto wsDestination_2.Range("A2") ' Select A2 on wsDestination_2
ActiveWindow.FreezePanes = True ' Freeze row 1
'
'---------------------------------------------------------------------------------------------------
'
Application.ScreenUpdating = True ' Turn ScreenUpdating back on
'
Debug.Print "Script completed in " & Timer - StartTime & " seconds." ' Display Completion time to the 'Immediate' window (CTRL+G) in the VBE
MsgBox "Completed in " & Timer - StartTime & " seconds." ' Display completion time to the pop up message box
End Sub
Public Function ReDimPreserve(ArrayNameToResize, NewRowUbound, NewColumnUbound)
'
Dim NewColumn As Long, NewRow As Long
Dim OldColumnLbound As Long, OldRowLbound As Long
Dim OldColumnUbound As Long, OldRowUbound As Long
Dim NewResizedArray() As Variant
'
ReDimPreserve = False
'
If IsArray(ArrayNameToResize) Then ' If the variable is an array then ...
OldRowLbound = LBound(ArrayNameToResize, 1) ' Save the original row Lbound to OldRowLbound
OldColumnLbound = LBound(ArrayNameToResize, 2) ' Save the original column Lbound to OldColumnLbound
'
ReDim NewResizedArray(OldRowLbound To NewRowUbound, OldColumnLbound To NewColumnUbound) ' Create a New 2D Array with same Lbounds as the original array
'
OldRowUbound = UBound(ArrayNameToResize, 1) ' Save row Ubound of original array
OldColumnUbound = UBound(ArrayNameToResize, 2) ' Save column Ubound of original array
'
For NewRow = OldRowLbound To NewRowUbound ' Loop through rows of original array
For NewColumn = OldColumnLbound To NewColumnUbound ' Loop through columns of original array
If OldRowUbound >= NewRow And OldColumnUbound >= NewColumn Then ' If more data to copy then ...
NewResizedArray(NewRow, NewColumn) = ArrayNameToResize(NewRow, NewColumn) ' Append rows/columns to NewResizedArray
End If
Next ' Loop back
Next ' Loop back
'
Erase ArrayNameToResize ' Free up the memory the Original array was taking
'
If IsArray(NewResizedArray) Then ReDimPreserve = NewResizedArray
End If
End FunctionPlease let me know what you think.
Likes/Dislikes?
Anyway to improve the results?
Please post what system you test it on also.
