FREEBIE: Macro to return count of string (e.g. function anme) in cell formulae by sheet

[Col Delane]

Here is a macro that I've developed to aid me in auditing and optimising a client's very large workbook (160Mb, with one sheet containing 7 million populated cells (data and formulae!http://www.mrexcel.com/forum/images/smilies/icon_eek.gif) to loop through each worksheet in the active workbook to ascertain the number of occurrences of a user-specified string within all formulae on the sheet and records the results in a new sheet added to the workbook.

If anyone has any ideas for improvement, or other comments, please fell free to let me know via this thread.

Enjoy!

Sub StringFunction_Count()
' Date:     17/01/2014
' Author:   Col Delane, CA, Financial Analyst/Modeller, Perth, Western Australia
' Purpose:  This macro loops through each worksheet in the active workbook to ascertain the number of occurrences
'            of a user-specified string within all formulae on the sheet and records the results, by sheet, in a new sheet added to the workbook.
'----------------------------------------------------------------------------------------------------------------------------------

    ' Dimension Variables
    Dim wks As Worksheet
    Dim wksRpt As Worksheet
    Dim wbk As Workbook
    
    Dim rngSearch As Range
    Dim rngC As Range
    
    Dim intRow As Integer
    
    Dim ipbResp As Variant
    Dim strFx As String
    Dim strMsg As String
    
    Dim lngClCount1 As Long
    Dim lngClCount2 As Long
  
    Dim lngFxCount1 As Long
    Dim lngFxCount2 As Long
    
    Dim iTimeStart As Double
  
  
    iTimeStart = VBA.Timer


    Set wbk = ActiveWorkbook
    strMsg = "Enter the text string or name of the function that you wish to count, and click OK."
    
    ' Get search string
    ipbResp = Application.InputBox(Prompt:=strMsg, Title:="String or Function Count", Type:=2)
    
    'Block IF #1
    If ipbResp = False Then
        MsgBox "Nothing entered!?"
        Exit Sub
    Else
        ' Append an open bracket to enable search to distinguish the search string within a sub-string within a string.(e.g. SUM within SUMIF and SUMIFs, or SUM and SUMIF within SUMIFs)"
        strFx = UCase(ipbResp) & "("

    End If  'Block IF #1
        
        
    ' Add sheet
    Application.Worksheets.Add
    ActiveSheet.Name = strFx & " Count"
    Set wksRpt = ActiveSheet
    With Range("A2")
        .Value = "Sheet"
        .Font.Bold = True
        .HorizontalAlignment = xlLeft
        .BorderAround (xlContinuous)
    End With
    With Range("B2")
        .Value = "Cell Count"
        .Font.Bold = True
        .WrapText = True
        .EntireColumn.HorizontalAlignment = xlCenter
        .BorderAround (xlContinuous)
        .EntireColumn.ColumnWidth = 10
    End With
    With Range("C2")
        .Value = "String/ Function Count"
        .Font.Bold = True
        .WrapText = True
        .EntireColumn.HorizontalAlignment = xlCenter
        .BorderAround (xlContinuous)
        .EntireColumn.ColumnWidth = 10
    End With
    Range("A1").Value = "Counts for: " & Left(strFx, Len(strFx) - 1)
    With Range("A1:C1")
        .Font.Bold = True
        .HorizontalAlignment = xlCenterAcrossSelection
        .BorderAround (xlContinuous)
    End With
    
    
    intRow = 3  ' First blank row
    
    ' Reset counters
    lngClCount1 = 0
    lngClCount2 = 0
    lngFxCount1 = 0
    lngFxCount2 = 0
    
    ' Loop thru all worksheets except the added sheet
    For Each wks In ActiveWorkbook.Worksheets
        'Block IF #2
        If wks.Name <> wksRpt.Name Then      '   "'StringFunction Count'"
        
            Set rngSearch = wks.UsedRange
            
            ' Loop thru all cells in the UsedRange of the wks
            For Each rngC In rngSearch
                
                ' See if strFx occurs in rngC & count occurrences
                lngFxCount1 = (Len(rngC.Formula) - Len(Replace(LCase(rngC.Formula), LCase(strFx), ""))) / Len(strFx)
                
                'Block IF #3
                If lngFxCount1 > 0 Then
                    ' Cell count = add 1 to total
                    lngClCount1 = lngClCount1 + 1
                    lngFxCount2 = lngFxCount2 + lngFxCount1
                    
                End If  'Block IF #3

                lngFxCount1 = 0

            Next rngC
       
            ' Capture total count for each sheet
            wksRpt.Cells(intRow, 1).Value = wks.Name
            With wksRpt.Cells(intRow, 2)
                .Value = lngClCount1
                .NumberFormat = "#,##0_);(#,##0); ""- """
            End With
            With wksRpt.Cells(intRow, 3)
                .Value = lngFxCount2
                .NumberFormat = "#,##0_);(#,##0); ""- """
            End With
            
            'Update / reset counters
            intRow = intRow + 1
            lngClCount2 = lngClCount2 + lngClCount1
            lngClCount1 = 0
            lngFxCount2 = 0
            
        End If  'Block IF #2
        
        Beep
        Beep
        
    Next wks
    
    wksRpt.Range("A1").EntireColumn.AutoFit
    
If lngClCount2 = 0 Then wksRpt.Delete
    
    MsgBox "Done. Time taken: " & VBA.Timer - iTimeStart & " seconds."
    
End Sub