Option Explicit
Sub Analyse_SumProduct_DONKEYOTE()
'-------------------------------------------------------------------------------------------------------------------------
'coded (poorly) by DonkeyOte Weds 22 to Fri 24 Oct 2008
'with not inconsiderable help from messrs. rorya, RichardSchollar & CornflakeGirl (muliebrity notwithstanding) - a.k.a. Rory, Richard & Emma.
'-------------------------------------------------------------------------------------------------------------------------
'abbreviations
'SP - SumProduct
'SPA - SumProduct Analysis
'-------------------------------------------------------------------------------------------------------------------------
'#DEFINE VARIABLES (Assign/Set where possible)
'-------------------------------------------------------------------------------------------------------------------------
'Range Type Variable(s)
'-------------------------------------------------------------------------------------------------------------------------
Dim r_c1 As Range: Set r_c1 = ActiveCell 'to hold active cell as range
'-------------------------------------------------------------------------------------------------------------------------
'String Type Variable(s)
'-------------------------------------------------------------------------------------------------------------------------
Dim s_c1_f As String: s_c1_f = ActiveCell.Formula 'to hold SP formula being analysed
Dim s_c1_f_res As Double 'to hold result of SP formula being analysed
Dim s_c1_f_delim As String 'to hold SP component delimiter (eg "," or "*") set via InputBox
Dim s_c1_f_comp As String 'component part of formula as stored in row 5 on SPA sheet
Dim s_e_msgbox_str As String 'used to hold error message displayed to end user on fatal error
Dim s_SPA_res_f As String 'used to hold formula written dynamically for 1+ column returns
'-------------------------------------------------------------------------------------------------------------------------
'Integer Type Variable(s)
'-------------------------------------------------------------------------------------------------------------------------
Dim i_c1_f_i As Integer 'to hold mid char point when iterating formula string
Dim i_c1_f_p_cnt As Integer 'to hold running total of parentheses
Dim i_c1_f_start As Integer 'to hold start char pos of SP component
Dim i_c1_f_c As Integer 'to hold count of "components" within SP formula
Dim i_insert_col_i As Integer 'used for resizing SPA where 1+ rows / 1 + columns (1+ component)
Dim i_reset As Integer 'reset flag
Dim i_SPA_res_i As Integer 'counter used in conjunction with s_SPA_res_f
Dim i_SPA_res_cnt As Integer 'counter used in conjunction with s_SPA_res_f
'-------------------------------------------------------------------------------------------------------------------------
'Long Type Variable(s)
'-------------------------------------------------------------------------------------------------------------------------
Dim l_calc As Long 'to hold calcuation settings
Dim l_e As Long 'used to hold possible cause of error on initial evaulation
Dim l_c1_f_comp_i As Long 'incremental column flag of component parts
Dim l_v_output_a_lbound As Long
Dim l_v_output_a_ubound As Long
Dim l_v_output_b_lbound As Long
Dim l_v_output_b_ubound As Long
Dim l_max_v_output_b_ubound As Long 'used for error handling in dealing with arrays
Dim l_v_output_item_i As Long 'used to populate col A on SPA
'-------------------------------------------------------------------------------------------------------------------------
'Variant / Undefined Type Variable(s)
'-------------------------------------------------------------------------------------------------------------------------
Dim v_c1_f_output 'used to store output array of component part
'-------------------------------------------------------------------------------------------------------------------------
'#END VARIABLES
'-------------------------------------------------------------------------------------------------------------------------
'-------------------------------------------------------------------------------------------------------------------------
'#SET APP SETTINGS (store current)
'-------------------------------------------------------------------------------------------------------------------------
l_calc = Application.Calculation
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 l_e = 0 And InStr(UCase(s_c1_f), "SUMPRODUCT") = 0 Then l_e = 1 'not a SUMPRODUCT formula
If l_e = 0 And Left(UCase(s_c1_f), 11) <> "=SUMPRODUCT" Then l_e = 2 'not self contained SUMPRODUCT (eg =IF(x=y,1,SUMPRODUCT())
If l_e = 0 And Len(s_c1_f) - Len(Replace(s_c1_f, "SUMPRODUCT", "")) > 10 Then l_e = 3 'embedded SUMPRODUCTS (too complex)
If l_e = 0 And InStr(r_c1.Parent.Name, "SPA") Then l_e = 4 'firing code from previously created SPA sheet!
'exit routine if formula not valid for analysis
If l_e <> 0 Then
Select Case l_e
Case 1
s_e_msgbox_str = "Formula is not a SUMPRODUCT Formula"
Case 2
s_e_msgbox_str = "Formula is not a self contained SUMPRODUCT Formula" & vbCrLf & vbCrLf & _
"If appropriate split the SUMPRODUCT(S) and evaluate each separately."
Case 3
s_e_msgbox_str = "Formula contains embedded SUMPRODUCTS and is thus deemed too complex." & vbCrLf & vbCrLf & _
"If appropriate split the SUMPRODUCT(S) and evaluate each separately."
Case 4
s_e_msgbox_str = "This Formula does not reside on a valid Sheet"
End Select
MsgBox s_e_msgbox_str, vbCritical, "Analysis Not Possible"
GoTo ExitHere
End If
'-------------------------------------------------------------------------------------------------------------------------
'#STEP 1a: DETERMINE DELIMITER (default to comma)
'-------------------------------------------------------------------------------------------------------------------------
s_c1_f_delim = ","
'-------------------------------------------------------------------------------------------------------------------------
'#STEP 1b: RESET POINT -- used only where original routine has reset
'(due to computational issues based on original delimiter and array dimensions)
'set delimiter to blank (handled in split)
'-------------------------------------------------------------------------------------------------------------------------
Reset:
If i_reset = 1 Then
s_c1_f_delim = "" 'reset delimimter
i_reset = 0 'reset the reset (!)
i_c1_f_c = 0 'reset count of components
s_c1_f = ActiveCell.Formula 'reset formula being analysed
End If
'-------------------------------------------------------------------------------------------------------------------------
'#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) = IIf(s_c1_f_delim = "", "NA", s_c1_f_delim)
Cells(5, 1) = "Component Part(s):"
Cells(6, 1) = "Array Row(s):"
Cells(7, 1) = "Array Column(s):"
Cells(9, 1) = "Record:"
'-------------------------------------------------------------------------------------------------------------------------
'#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
'default running count of parentheses to be 0
i_c1_f_p_cnt = 0
'if delimiter is blank this is because of a reset which means the entire formula must be computed without components
If s_c1_f_delim <> "" Then
'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 ",", "*", ";"
'current char appears to be delimiter however only valid end point IF count of parentheses is 0
'if comma and count of parentheses is 0 then must be delimiter whether defined or not...
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
End If
'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)
'-------------------------------------------------------------------------------------------------------------------------
'default starting position to B (first column containing a component)
l_c1_f_comp_i = 2
'iterate components (use Do Until as opposed to For Next given requisite column insertions below for multi column output)
Do Until Cells(5, l_c1_f_comp_i) = ""
'set result header
Cells(9, 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)
'set array boundaries
'1+ row / 1 column will generate (1 to x (rows), 1 to 1 (columns))
'1 row / 1 + column will generate (1 to x (columns), Nothing)
'1+ row / 1 + column will generate (1 to x (rows), 1 to y (columns))
On Error Resume Next
l_v_output_a_lbound = LBound(v_c1_f_output, 1)
l_v_output_a_ubound = UBound(v_c1_f_output, 1)
l_v_output_b_lbound = LBound(v_c1_f_output, 2)
l_v_output_b_ubound = UBound(v_c1_f_output, 2)
'handling first component part ?
If l_c1_f_comp_i = 2 Then
'default max l_v_output_b_ubound to be first b_ubound value (set on first component)
'used to establish later as to whether or not component parts of differing dimensions (requiring reset of calculation)
l_max_v_output_b_ubound = l_v_output_b_ubound
'populate SPA Col A with range details ?
For l_v_output_item_i = 1 To Application.WorksheetFunction.Max(l_v_output_a_ubound, l_v_output_b_ubound) Step 1
Cells(l_v_output_item_i + 9, 1) = l_v_output_item_i
Next l_v_output_item_i
End If
'list array dimensions in SPA sheet -- if b array is nothing then purely column based SUMPRODUCT so rows = 0
Select Case l_v_output_b_ubound
Case 0
'just columns
Cells(6, l_c1_f_comp_i) = 1
Cells(7, l_c1_f_comp_i) = l_v_output_a_ubound
Case Else
'both rows and columns
Cells(6, l_c1_f_comp_i) = l_v_output_a_ubound
Cells(7, l_c1_f_comp_i) = l_v_output_b_ubound
End Select
'before doing anything check current l_v_output_b_ubound to max thus far
'point being if latest ubound value > prior max then need to do a singular return for this entire formula (no delimiter)
If l_v_output_b_ubound <> l_max_v_output_b_ubound Then
'reset
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
r_c1.Parent.Select
i_reset = 1
GoTo Reset
End If
'evaluate component, take different actions based on array boundaries
On Error GoTo Fatality
Select Case l_v_output_b_ubound
Case 0
'if 0 results require transposition (1+ columns, 1 row)
Cells(10, l_c1_f_comp_i).Resize(UBound(v_c1_f_output)).Value = Application.Transpose(v_c1_f_output)
l_c1_f_comp_i = l_c1_f_comp_i + 1
Case 1
'1+ rows, 1 column
Cells(10, l_c1_f_comp_i).Resize(UBound(v_c1_f_output)).Value = v_c1_f_output
l_c1_f_comp_i = l_c1_f_comp_i + 1
Case Is > 1
'1+ rows, 1+ columns
'multi dimensional array so EITHER repeat evaluation but with SUM where SUM(components) = 1 or resize everything ?
'base on number of components... if 1 return 1 answer
Select Case i_c1_f_c
Case 1
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(10, l_c1_f_comp_i).Resize(UBound(v_c1_f_output)).Value = v_c1_f_output
l_c1_f_comp_i = l_c1_f_comp_i + 1
Case Else
'resize SPA sheet and write back multi dimensional values ?
'insert columns based on adjacent column to right of current column
For i_insert_col_i = 1 To (l_v_output_b_ubound - 1)
Columns(l_c1_f_comp_i + 1).Insert
Next i_insert_col_i
Cells(10, l_c1_f_comp_i).Resize(UBound(v_c1_f_output, 1), UBound(v_c1_f_output, 2)).Value = v_c1_f_output
'now completed insertion of code - adjust l_c1_f_comp_i counter such that next cell moved to contains next component (now moved)
l_c1_f_comp_i = l_c1_f_comp_i + i_insert_col_i
End Select
End Select
'reset handler to default (for now...)
On Error GoTo 0
Loop
'insert final column to total results
Cells(10, Columns.Count).End(xlToLeft).Offset(-1, 1).Value = "Total(s)"
'different totals depending on whether the component arrays > 1 column
'can check this by comparing:
'count of non-blanks in first row of results (10) (less 1 given col A populated with non array result)
'count of "Result" headers in header row (9)
'if match then arrays are single column/row arrays and can use a PRODUCT based approach
Select Case Application.WorksheetFunction.CountIf(Range("9:9"), "Result(s)") = Application.WorksheetFunction.CountA(Range("10:10")) - 1
Case True
Cells(10, 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]))"
Case False
'in these instances need to SUMPRODUCT the different arrays rather than PRODUCT the entire row
'urgh... need to construct the formula on the fly given could have variable numbers of 1+ column arrays
s_SPA_res_f = "=SUMPRODUCT("
For i_SPA_res_i = 2 To (l_c1_f_comp_i - 1)
Select Case UCase(Cells(9, i_SPA_res_i))
Case ""
'column must be added to sum product so continue
Case Else
'increment instances where RESULT found (ie commencement of component results)
i_SPA_res_cnt = i_SPA_res_cnt + 1
'must be commencement of new range
'close off first range in formula first (if necessary)
If i_SPA_res_cnt > 1 Then
s_SPA_res_f = s_SPA_res_f & "RC" & i_SPA_res_i - 1 & ","
End If
'create new range for SUMPRODUCT
s_SPA_res_f = s_SPA_res_f & "RC" & i_SPA_res_i & ":"
End Select
Next i_SPA_res_i
'add last close to formula (given last header in range will be blank
s_SPA_res_f = s_SPA_res_f & "RC" & i_SPA_res_i - 1 & ")"
'insert formula across result range
Cells(10, l_c1_f_comp_i).Resize(UBound(v_c1_f_output)).FormulaR1C1 = s_SPA_res_f
End Select
'totals column
With Cells(10, l_c1_f_comp_i).Resize(UBound(v_c1_f_output))
'overwrite formulae with valuse (performance)
.Formula = Cells(10, l_c1_f_comp_i).Resize(UBound(v_c1_f_output)).Value
'.NumberFormat = "#,##0.0#;[Red](#,##0.0#);-"
'bold total column
.Font.Bold = True
End With
'-------------------------------------------------------------------------------------------------------------------------
'#STEP 5: FORMAT SPA SHEET
'-------------------------------------------------------------------------------------------------------------------------
'clean up excess id's in A (if reset invoked may have excess)
Range(Cells(Rows.Count, 2).End(xlUp).Offset(1, -1), Cells(Rows.Count, 1)).ClearContents
Columns(1).AutoFit
Range(Cells(5, 2), Cells(9, 2).End(xlToRight)).Columns.AutoFit
Cells(10, 1).Select
ActiveWindow.FreezePanes = True
'-------------------------------------------------------------------------------------------------------------------------
'#EXIT POINT
'-------------------------------------------------------------------------------------------------------------------------
ExitHere:
'-------------------------------------------------------------------------------------------------------------------------
'#RESET APP SETTINGS (based on store)
'-------------------------------------------------------------------------------------------------------------------------
With Application
.ScreenUpdating = True
Select Case l_calc
Case -4105
.Calculation = xlCalculationAutomatic
Case -4135
'no action (currently manual)
Case 2
.Calculation = xlCalculationSemiautomatic
End Select
End With
'-------------------------------------------------------------------------------------------------------------------------
'#END
'-------------------------------------------------------------------------------------------------------------------------
Exit Sub
Fatality:
MsgBox "Fatal Error Occurred Processing Component Part", vbCritical, "Fatal Error"
If InStr(ActiveSheet.Name, "SPA_") Then
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
r_c1.Parent.Select
End If
Resume ExitHere
End Sub
)
