Option Explicit
Sub Analyse_SumProduct_DONKEYOTE()
'-------------------------------------------------------------------------------------------------------------------------
'coded (poorly) by DonkeyOte Weds 22 Oct 2008
'tough bits coded by messrs. rorya, RichardSchollar & CornflakeGirl (muliebrity notwithstanding) - a.k.a. Rory, Richard & Emma.
'abbreviations
'SP - SumProduct
'SPA - SumProduct Analysis
'-------------------------------------------------------------------------------------------------------------------------
'#DEFINE VARIABLES (Assign/Set where possible)
'-------------------------------------------------------------------------------------------------------------------------
Dim r_c1 As Range: Set r_c1 = ActiveCell 'to hold active cell as range
Dim s_c1_f As String: s_c1_f = ActiveCell.formula 'to hold SP formula being analysed
Dim s_c1_f_res As Long 'to hold result of SP formula being analysed
Dim i_c1_f_i As Long 'to hold mid char point when iterating formula string
Dim i_c1_f_p_cnt As Long 'to hold running total of parentheses
Dim i_c1_f_start As Long 'to hold start char pos of SP component
Dim s_c1_f_delim As String 'to hold SP component delimiter (eg "," or "*") set via InputBox
Dim i_c1_f_c As Integer 'to hold count of "components" within SP formula
Dim l_c1_f_comp_i As Long 'incremental column flag of component parts
Dim s_c1_f_comp As String 'component part of formula as stored in row 5 on SPA sheet
Dim v_c1_f_output 'used to store result of component part
Dim e As Long 'used to hold possible cause of error on initial evaulation
Dim lngColCount As Long 'will be used to test if output requires transposition
'-------------------------------------------------------------------------------------------------------------------------
'#SET APP SETTINGS
'-------------------------------------------------------------------------------------------------------------------------
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
'-------------------------------------------------------------------------------------------------------------------------
'#STEP 1: VALIDATE FORMULA BEING ANALYSED -- EXIT IF INAPPROPRIATE FOR THIS ROUTINE
'-------------------------------------------------------------------------------------------------------------------------
On Error Resume Next
s_c1_f_res = Evaluate(s_c1_f)
On Error GoTo 0
If InStr(UCase(s_c1_f), "=SUMPRODUCT") = 0 Then e = 1 'although formula is valid it's not a SUMPRODUCT formula!
If InStr(r_c1.Parent.Name, "SPA") Then e = 1 'firing code from previously created SPA sheet!
'exit routine if formula not valid for analysis
If e <> 0 Then
MsgBox "Current Formula Not Valid for SUMPRODUCT Analysis"
GoTo ExitHere
End If
'-------------------------------------------------------------------------------------------------------------------------
'#STEP 1a: DETERMINE DELIMITER (let user decide...)
'-------------------------------------------------------------------------------------------------------------------------
s_c1_f_delim = Application.InputBox("Enter Delimiter" & vbCrLf & "Note: Normally one of , * ;", "Delimiter", ",", Type:=2)
Select Case Trim(s_c1_f_delim)
Case ",", "*", ";"
Case Else
MsgBox s_c1_f_delim & "Not Valid for SUMPRODUCT Analysis"
GoTo ExitHere
End Select
'-------------------------------------------------------------------------------------------------------------------------
'#STEP 2: INSERT A NEW SHEET ON WHICH THE SPA WILL BE HELD
'set name convention to utilise system time so as to remove possibility of duplication without need for ws testing / deletion
'set up headers
'-------------------------------------------------------------------------------------------------------------------------
Sheets.Add
ActiveSheet.Name = "SPA_" & Format(Now(), "DDMMYY_HHMMSS")
Cells(1, 1) = "Formula Location:"
ActiveSheet.Hyperlinks.Add Anchor:=Cells(1, 2), Address:="", SubAddress:="'" & r_c1.Parent.Name & "'!" & r_c1.Address(0, 0), TextToDisplay:="'" & r_c1.Parent.Name & "'!" & r_c1.Address
Cells(2, 1) = "Formula: "
Cells(2, 2) = "'" & s_c1_f
Cells(3, 1) = "Result: "
Cells(3, 2) = s_c1_f_res
Cells(4, 1) = "Delimiter:"
Cells(4, 2) = s_c1_f_delim
Cells(5, 1) = "Component Part(s):"
Cells(7, 1) = "Row/Column:"
'-------------------------------------------------------------------------------------------------------------------------
'#STEP 3: BEGINNING STRIPPING DOWN FORMULA INTO "COMPONENT" PARTS
'first remove =SUMPRODUCT() leaving just innards behind...
'loop the remaining string using predefined component "delimiter" (eg "," or "*") to break into parts (check parentheses)
'-------------------------------------------------------------------------------------------------------------------------
s_c1_f = Replace(s_c1_f, "=SUMPRODUCT(", "")
s_c1_f = Left(s_c1_f, Len(s_c1_f) - 1)
'default start pos of string to be 1
i_c1_f_start = 1
'iterate formula string
For i_c1_f_i = i_c1_f_start To Len(s_c1_f) Step 1
'ascertain current character and act appropriately
Select Case Mid(s_c1_f, i_c1_f_i, 1)
Case "("
'opening parentheses so add 1 to parentheses count
i_c1_f_p_cnt = i_c1_f_p_cnt + 1
Case ")"
'closing parentheses so remove 1 from parentheses count
i_c1_f_p_cnt = i_c1_f_p_cnt - 1
Case s_c1_f_delim
'current char appears to be delimiter however only valid end point IF count of parentheses is 0
If i_c1_f_p_cnt = 0 Then
'increment count of components
i_c1_f_c = i_c1_f_c + 1
'paste formula component as header in column B onwards (row 5)
Cells(5, 1 + i_c1_f_c) = Chr(34) & Mid(s_c1_f, i_c1_f_start, i_c1_f_i - i_c1_f_start) & Chr(34)
'reset start pos to be current string pos + 1
i_c1_f_start = i_c1_f_i + 1
End If
End Select
Next i_c1_f_i
'insert final component
'increment count of components
i_c1_f_c = i_c1_f_c + 1
'paste formula component as header in column B onwards (row 5)
Cells(5, 1 + i_c1_f_c) = Chr(34) & Mid(s_c1_f, i_c1_f_start, i_c1_f_i - 1) & Chr(34)
'-------------------------------------------------------------------------------------------------------------------------
'#STEP 4: EVALUATE EACH COMPONENT PART & WRITE BACK RESULTS TO SPA SHEET (add total column)
'-------------------------------------------------------------------------------------------------------------------------
For l_c1_f_comp_i = 2 To Cells(5, Columns.Count).End(xlToLeft).Column Step 1
Cells(7, l_c1_f_comp_i) = "Result(s)"
s_c1_f_comp = Cells(5, l_c1_f_comp_i)
s_c1_f_comp = "IF(ROW(1:1)," & Mid(Left(s_c1_f_comp, Len(s_c1_f_comp) - 1), 2) & ")"
v_c1_f_output = r_c1.Parent.Evaluate(s_c1_f_comp)
'test to see if range horizontal as opposed to vertical -- UBound(output,2) will generate error if so
'default value of lngColCount will be 0 if error
On Error Resume Next
lngColCount = UBound(v_c1_f_output, 2)
On Error GoTo Fatality
'if 0 then results require transposition
Select Case lngColCount
Case 0
Cells(8, l_c1_f_comp_i).Resize(UBound(v_c1_f_output)).Value = Application.Transpose(v_c1_f_output)
Case Is > 1
'multi dimensional array so repeat evaluation but with SUM
s_c1_f_comp = Replace(s_c1_f_comp, "ROW(1:1),", "ROW(1:1),SUM(") & ")"
v_c1_f_output = r_c1.Parent.Evaluate(s_c1_f_comp)
Cells(8, l_c1_f_comp_i).Resize(UBound(v_c1_f_output)).Value = v_c1_f_output
Case Else
Cells(8, l_c1_f_comp_i).Resize(UBound(v_c1_f_output)).Value = v_c1_f_output
End Select
On Error GoTo 0
Next l_c1_f_comp_i
Cells(5, Columns.Count).End(xlToLeft).Offset(2, 1).Value = "Total(s)"
Cells(8, l_c1_f_comp_i).Resize(UBound(v_c1_f_output)).FormulaR1C1 = "=IF(OR(SUMPRODUCT(--(ISNUMBER(--(RC2:RC[-1]))=FALSE)),COUNTIF(RC2:RC[-1],FALSE)),0,PRODUCT(RC2:RC[-1]))"
Cells(8, l_c1_f_comp_i).Resize(UBound(v_c1_f_output)).formula = Cells(8, l_c1_f_comp_i).Resize(UBound(v_c1_f_output)).Value
Cells(8, l_c1_f_comp_i).Resize(UBound(v_c1_f_output)).Font.Bold = True
'-------------------------------------------------------------------------------------------------------------------------
'#STEP 5: FORMAT SPA SHEET
'-------------------------------------------------------------------------------------------------------------------------
Columns(1).AutoFit
Range(Cells(5, 2), Cells(5, 2).End(xlToRight)).Columns.AutoFit
'-------------------------------------------------------------------------------------------------------------------------
'#EXIT POINT
'-------------------------------------------------------------------------------------------------------------------------
ExitHere:
'-------------------------------------------------------------------------------------------------------------------------
'#RESET APP SETTINGS
'-------------------------------------------------------------------------------------------------------------------------
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
'-------------------------------------------------------------------------------------------------------------------------
'#END
'-------------------------------------------------------------------------------------------------------------------------
Exit Sub
Fatality:
MsgBox "Fatal Error Occurred Processing Component Part", vbCritical, "Fatal Error"
Resume ExitHere
End Sub
