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 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 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 l_v_output_a_lbound, l_v_output_a_ubound, l_v_output_b_lbound, 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 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 s_SPA_res_f As String 'used to hold formula written dynamically for 1+ column returns
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
'-------------------------------------------------------------------------------------------------------------------------
'#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 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) = "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
'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 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
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)
'default max l_v_output_b_ubound to be first b_ubound value
If l_c1_f_comp_i = 2 Then l_max_v_output_b_ubound = l_v_output_b_ubound
'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 dividing the count of non-blanks in first row of results (10) against count of non-blanks in header row (9)
Select Case Application.WorksheetFunction.CountIf(Range("9:9"), "Result(s)") = Application.WorksheetFunction.CountA(Range("10:10"))
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
Cells(10, l_c1_f_comp_i).Resize(UBound(v_c1_f_output)).Formula = Cells(10, l_c1_f_comp_i).Resize(UBound(v_c1_f_output)).Value
Cells(10, 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(9, 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
