Col Delane
Active Member
- Joined
- Jan 14, 2014
- Messages
- 304
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!
If anyone has any ideas for improvement, or other comments, please fell free to let me know via this thread.
Enjoy!
Code:
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