VBA Code:
Sub VBA_ArrayFormulaChopperV1()
'
' Inspired by some code originally posted by B_Nut.
' https://stackoverflow.com/questions/22949221/array-formula-with-more-than-255-characters
'
' This current code has been drastically changed. It is designed to create the code needed to 'work around' a vba A1 notation array formula
' that is longer than the 255 acceptable vba length allowed.
'
Dim FirstIfLoop As Boolean
Dim ArrayRow As Long
Dim IfCurrentStringPosition As Long, IfEndStringPosition As Long, IfStartStringPosition As Long
Dim i As Long
Dim LastRow As Long, UniqueRowNumber As Long
Dim LeftParenthesisCount As Long
Dim MaxFormulaStringLength As Long, OriginalFormulaStringLength As Long
Dim ReplacementCharacter As Long
Dim ReplacementStringsLengthArray() As Long
Dim CurrentIfStringCharacter As String
Dim FormulaToWrite As String
Dim IfFunction As String
Dim ReplacementStringName As String
Dim ReplacementStringsArray() As String, ReplacementStringsNameArray() As String, UniqueAddressStringsArray() As String
Dim HeaderTitlesToPaste As Variant
'
' \/ \/ \/ Set this \/ \/ \/ To the vba array formula that is too long for vba to handle
FormulaToWrite = "=IFERROR(IF(ROW(B2)<=SMALL(IF((ABS(G2-$G$2:$G$20000)<=1)*(C2=$C$2:$C$20000)*(B2=$B$2:$B$20000),ROW($A$2:$A$20000),""""),MIN(SUM(IF(($C$2:$C$20000=C2)*(ABS(G2-$G$2:$G$20000)<=1)*($B$2:$B$20000=""PORTAL""),1,0)),SUM(IF(($C$2:$C$20000=C2)*(ABS(G2-$G$2:$G$20000)<=1)*($B$2:$B$20000=""TALLY""),1,0)))),""Matched"",NA()),NA())"
'
ReplacementStringName = "ReplacementString" ' <--- Set this to the name that you want for the replacement strings
UniqueRowNumber = 9999 ' <--- Set this to a row number that is not used in the array formula
MaxFormulaStringLength = 155 ' <--- Set this to the maximum length of the replacement formula string you want to create
'
ArrayRow = -1 ' Initialize ArrayRow
OriginalFormulaStringLength = Len(FormulaToWrite) - 3 ' Get the length of the original submitted vba formula
ReplacementCharacter = Asc("A") ' Set the initial ReplacementCharacter to use for replacement strings created
'
IfStartStringPosition = InStr(1, FormulaToWrite, "IF(") ' Set IfStartStringPosition if an if funtion is found in the formula
'
Do While IfStartStringPosition > 0 ' Loop while If functions found
LeftParenthesisCount = 0 ' Initialize LeftParenthesisCount
IfEndStringPosition = 0 ' Initialize IfEndStringPosition
IfCurrentStringPosition = IfStartStringPosition ' Initialize IfCurrentStringPosition to IfStartStringPosition
'
Do While IfEndStringPosition = 0 ' Loop until end of if function found - error if not
CurrentIfStringCharacter = Mid(FormulaToWrite, _
IfCurrentStringPosition, 1) ' Set CurrentIfStringCharacter
'
If CurrentIfStringCharacter = "(" Then ' If CurrentIfStringCharacter = a Left parenthesis then ...
LeftParenthesisCount = LeftParenthesisCount + 1 ' Increment LeftParenthesisCount
End If
'
If CurrentIfStringCharacter = ")" Then ' If CurrentIfStringCharacter = a Right parenthesis then ...
LeftParenthesisCount = LeftParenthesisCount - 1 ' Decrement LeftParenthesisCount
'
If LeftParenthesisCount = 0 Then ' If LeftParenthesisCount = 0 then ...
IfEndStringPosition = IfCurrentStringPosition ' Set IfEndStringPosition = IfCurrentStringPosition
End If
End If
'
IfCurrentStringPosition = IfCurrentStringPosition + 1 ' Increment IfCurrentStringPosition
'
If IfCurrentStringPosition > Len(FormulaToWrite) And _
IfEndStringPosition = 0 Then ' Returns an error if IfCurrentStringPosition is greater than the formula string
MsgBox "The entered FormulaToWrite is not a valid English" & _
" formula: " & """" & FormulaToWrite & """" ' Alert user of error
End
End If
Loop ' Loop back
'
If Not FirstIfLoop Then ' If this isn't the FirstIfLoop then ...
FirstIfLoop = True ' Set FirstIfLoop = True
Else ' Else ...
IfFunction = Mid(FormulaToWrite, IfStartStringPosition, _
(IfEndStringPosition + 1 - (IfStartStringPosition))) ' Save the IfFunction portion of the formula
End If
'
If Len(IfFunction) > 0 And Len(IfFunction) <= _
MaxFormulaStringLength Then ' IF Length of the IfFunction formula <= MaxFormulaStringLength then ...
ArrayRow = ArrayRow + 1 ' Increment ArrayRow
'
ReDim Preserve ReplacementStringsArray(ArrayRow) ' Resize ReplacementStringsArray
ReDim Preserve ReplacementStringsLengthArray(ArrayRow) ' Resize ReplacementStringsLengthArray
ReDim Preserve ReplacementStringsNameArray(ArrayRow) ' Resize ReplacementStringsNameArray
ReDim Preserve UniqueAddressStringsArray(ArrayRow) ' Resize UniqueAddressStringsArray
'
ReplacementStringsArray(ArrayRow) = "'=" & Replace(IfFunction, _
Chr(34), Chr(34) & Chr(34)) ' Write the IfFunction string into ReplacementStringsArray
ReplacementStringsLengthArray(ArrayRow) = _
Len(ReplacementStringsArray(ArrayRow)) - 2 ' Save the Length of the IfFunction string into ReplacementStringsLengthArray
ReplacementStringsNameArray(ArrayRow) = _
ReplacementStringName & ArrayRow + 1 ' Save the ReplacementStringName into ReplacementStringsNameArray
UniqueAddressStringsArray(ArrayRow) = _
Chr(ReplacementCharacter) & UniqueRowNumber ' Save the UniqueAddressString into UniqueAddressStringsArray
'
FormulaToWrite = Replace(FormulaToWrite, IfFunction, _
Chr(ReplacementCharacter) & UniqueRowNumber) ' Substitute the if function into the formula
ReplacementCharacter = ReplacementCharacter + 1 ' Increment ReplacementCharacter
End If
'
IfStartStringPosition = InStr(IfStartStringPosition + 1, _
FormulaToWrite, "IF(") ' Set IfStartStringPosition to the beginning of the next If function
Loop ' Loop back
'
'--------------------------------------------------------------------------
'
FormulaToWrite = Replace(FormulaToWrite, Chr(34), Chr(34) & Chr(34)) ' Convert FormulaToWrite to vba array formulaa
'
Range("A1:E" & Range("C" & Rows.Count).End(xlUp).Row).Clear ' Clear previous results from sheet
'
Range("A2").Resize(UBound(UniqueAddressStringsArray, 1) + 1) = _
Application.Transpose(UniqueAddressStringsArray) ' Display UniqueAddressStringsArray to column A
Range("E2") = OriginalFormulaStringLength ' Display OriginalFormulaStringLength to sheet
Range("B6").Resize(UBound(ReplacementStringsNameArray, 1) + 1) = _
Application.Transpose(ReplacementStringsNameArray) ' Display ReplacementStringsNameArray to column B
'
HeaderTitlesToPaste = Array("Substituted Formula Strings ...", _
"Replacement String Names ...", "Final Formula with replacements", _
"String Lengths", "Original VBA Formula Length") ' Create Headers to write to sheet
Range("A1:E1").Value = HeaderTitlesToPaste ' Write headers to Sheet
Range("C2") = "'" & FormulaToWrite ' Display shortened formula to sheet
Range("D2") = Len(FormulaToWrite) - 1 ' Display the length of the shortened formula
Range("C5") = "Replacement Strings ..." ' Display Header to sheet
'
Range("C6").Resize(UBound(ReplacementStringsArray, 1) + 1) = _
Application.Transpose(ReplacementStringsArray) ' Display ReplacementStringsArray to sheet
Range("D6").Resize(UBound(ReplacementStringsLengthArray, 1) + 1) = _
Application.Transpose(ReplacementStringsLengthArray) ' Display ReplacementStringsLengthArray to sheet
'
LastRow = Range("C" & Rows.Count).End(xlUp).Row + 3 ' Calculate next row to write to
'
Range("C" & LastRow) = "Example VBA coding ..." ' Display next heading to sheet
'
Range("A1:E1,C5,C" & LastRow).HorizontalAlignment = xlCenter ' Center the headings
Range("A1:E1,C5,C" & LastRow).Font.Bold = True ' Bold the headings
'
For i = 1 To UBound(ReplacementStringsArray) + 1 ' Loop through the ReplacementStringsArray
Range("C" & LastRow + i) = ReplacementStringName & i & " = " & _
Chr(34) & Right$(ReplacementStringsArray(i - 1), _
Len(ReplacementStringsArray(i - 1)) - 2) & Chr(34) ' Display the corrected ReplacementStringsArray to sheet
Next ' Loop back
'
Range("C" & Range("C" & Rows.Count).End(xlUp).Row + 1) = _
"With Range(""J2"") ' <--- Adjust this as needed" ' Display first line of suggested code to sheet
'
Range("C" & Range("C" & Rows.Count).End(xlUp).Row + 1) = ".FormulaArray =" _
& Chr(34) & FormulaToWrite & Chr(34) ' Display next line of suggested code to sheet
'
LastRow = Range("C" & Rows.Count).End(xlUp).Row ' Calculate LastRow
'
For i = 1 To UBound(UniqueAddressStringsArray, 1) + 1 ' Loop through UniqueAddressStringsArray
Range("C" & LastRow + i) = ".Replace " & Chr(34) & _
UniqueAddressStringsArray(i - 1) & Chr(34) & ", " & _
ReplacementStringsNameArray(i - 1) & ", xlPart" ' Display corrected UniqueAddressStringsArray to sheet
Next ' Loop back
'
Range("C" & Range("C" & Rows.Count).End(xlUp).Row + 1) = "End With" ' Display last line of suggested code to sheet"
'
Range("A1:E1").EntireColumn.AutoFit ' Autofit columns A:E
Range("D:E").HorizontalAlignment = xlCenter ' Center Columns D;E
End SubPlease Let me know of any suggestions or corrections to make.
Sample result:
| FormulaChopperV1.xlsm | ||||||||
|---|---|---|---|---|---|---|---|---|
| A | B | C | D | E | F | |||
| 1 | Substituted Formula Strings ... | Replacement String Names ... | Final Formula with replacements | String Lengths | Original VBA Formula Length | |||
| 2 | A9999 | =IFERROR(IF(ROW(B2)<=SMALL(A9999,MIN(SUM(B9999),SUM(C9999))),""Matched"",NA()),NA()) | 83 | 309 | ||||
| 3 | B9999 | |||||||
| 4 | C9999 | |||||||
| 5 | Replacement Strings ... | |||||||
| 6 | ReplacementString1 | =IF((ABS(G2-$G$2:$G$20000)<=1)*(C2=$C$2:$C$20000)*(B2=$B$2:$B$20000),ROW($A$2:$A$20000),"""") | 92 | |||||
| 7 | ReplacementString2 | =IF(($C$2:$C$20000=C2)*(ABS(G2-$G$2:$G$20000)<=1)*($B$2:$B$20000=""PORTAL""),1,0) | 80 | |||||
| 8 | ReplacementString3 | =IF(($C$2:$C$20000=C2)*(ABS(G2-$G$2:$G$20000)<=1)*($B$2:$B$20000=""TALLY""),1,0) | 79 | |||||
| 9 | ||||||||
| 10 | ||||||||
| 11 | Example VBA coding ... | |||||||
| 12 | ReplacementString1 = "IF((ABS(G2-$G$2:$G$20000)<=1)*(C2=$C$2:$C$20000)*(B2=$B$2:$B$20000),ROW($A$2:$A$20000),"""")" | |||||||
| 13 | ReplacementString2 = "IF(($C$2:$C$20000=C2)*(ABS(G2-$G$2:$G$20000)<=1)*($B$2:$B$20000=""PORTAL""),1,0)" | |||||||
| 14 | ReplacementString3 = "IF(($C$2:$C$20000=C2)*(ABS(G2-$G$2:$G$20000)<=1)*($B$2:$B$20000=""TALLY""),1,0)" | |||||||
| 15 | With Range("J2") ' <--- Adjust this as needed | |||||||
| 16 | .FormulaArray ="=IFERROR(IF(ROW(B2)<=SMALL(A9999,MIN(SUM(B9999),SUM(C9999))),""Matched"",NA()),NA())" | |||||||
| 17 | .Replace "A9999", ReplacementString1, xlPart | |||||||
| 18 | .Replace "B9999", ReplacementString2, xlPart | |||||||
| 19 | .Replace "C9999", ReplacementString3, xlPart | |||||||
| 20 | End With | |||||||
| 21 | ||||||||
Sheet1 | ||||||||
