Gentlemen. After 6 years I stumbled on this thread. It seems as if it's the only source for what I need for my work in the whole of internet. So, very impressive, thank you very much. I need this code because I'm a strength analyst, and an Excel heavy user. I need to be able to compare the formulas straight to the equations presented in standards, because it takes effort to figure out the corresponding measure for each address in the formula. In order to reach the required level of automation I taped PEH's code with the code by M-- in the thread:
How to run a string as a command in VBA
M--'s code creates, writes, runs and deletes Module1 in VBA editor. That way PEH's command to modify the equation shape can be constucted and run as a string. I was not able to solve the initiation of the equation ether, so the first equation opened will modify. I call my macro from Developer:Macros. In the pictures below are the views of my VBA Editor and Calculation sheet. Create similar Excel, and create a userform by clicking Insert: UserForm in the VBA editor. Insert textbox and a button objects to the userform. Clicking them opens the list of object attributes, and mark the name of the textbox as "TxtCellAddress" and the name of the button as "CommmandButton1". Then create two new modules by clicking Insert: Module twise. Then delete Module1. In Module2 create the sub (presented in the picture) that initiates the userform when macro is called.
The UserForm1 in the VBA editor has "View object" and "View code" buttons in the top left corner of the project vindow. Click on the "View code" button to view the canvas, and paste the code below on it. (Check each line first to prevent malice code!)
Option Explicit
Private Sub CommandButton1_Click()
On Error GoTo ErrorHandler
'UserForm1 contains a textbox(TxtCellAddress) and a button(CommandButton1).
'When user writes CELL address, and clicks the button, the first shape on the
'ActiveSheet(In this case, the shape is an equation box, which has previously
'been plased on the sheet manually.) is evoked. This program modifies the
'equation box to present the formula.
'This code requires lowering your Excel security. Do not open Excel files sent
'by other people while you work, and please remember to reverse these changes
'after your work. Remember that malicious macros open, when Excel workbook is
'opened. From File: Options: Trust Center: Macro Settings:
'Click: Enable VBA macros(not recommended; potentially dangerous code can run)
'Click: Trust access to the VBA project object model
'The formula to be presented in equation box is obtained as a string value
'from a cell the user must name in in the textbox. First the string containing
'the formula is checked for INDIRECT() functions, that are evaluated.
'The string containing the formula is then processed so, that the cell
'addresses in formula are replaced by the names of the measures they keep. The
'names of the measures may consist of symbols or they may have two parts,
'first the normal part, and second the subscripted part. The default font of
'Excel Equation Editor is "Cambria Math". I dont know how to change that, so
'it is advisable to use that font in the column of the names of the measures.
'In the ActiveSheet the calculation is set on column J, The description of the
'measures are on column D, and the names of the measures are on column E. The
'identifications of the calculation are marked on row 8. When the calculation
'is copied column to column for say analysis of flanges in different pipe
'locations, the identification helps, and thus we also want to see it in the
'equation box. The string with the formula is then translated to a string
'consisting of a set of character commands, readable by the equation editor.
'Next a subroutine ExecuteString() is called. It creates Module1, and writes
'the subs foo(), MakeEquationLinear() and MakeEquationProfessional(), and then
'calls a subroutine foo() to be executed. Subroutine foo() sends the info to
'the Equation Editor, that one has to previously open manually. The code
'expects the Equation Editor to appear in the first shape i.e.
'ActiveSheet.Shapes(1). Afterwards Module1 is deleted. Put the subroutine that
'calls Userform1 to another module, because Module1 is reserved for the
'operation of this code.
Dim start As Long
Dim count As Integer
Dim aihio As String
Dim measureText As String
Dim aihioLen As Integer
Dim state As Integer
Dim char As String * 1
Dim prevChar As String * 1
Dim i As Long
Dim ii As Integer
Dim originalText As String
Dim cellAddress As String
Dim measure(0 To 1000) As String
Dim indirectNum As Integer
Dim indirectLocation(1 To 1000) As Long
Dim indirectLength(1 To 1000) As Integer
Dim indirectRef As String
Dim iE As String
Dim rowNum As Integer
Dim colNum As Integer
Dim stringToRun As String
Dim columnOfMeasureNames As String
Dim CN As Integer
Dim rowOfItemNames As Integer
Dim rE As Range
columnOfMeasureNames = "C"
rowOfItemNames = 8
CN = Columns(columnOfMeasureNames).Column
'Get cell adress from textbox. "Me" refers to the userform object. Because
'this subroutine is in the UserForm1 module the precise object identification
'is not required.
cellAddress = Me.TxtCellAddress.Value
'Get row number of the cell named in textbox
rowNum = ActiveSheet.Range(cellAddress).Row
'Get column number of the cell named in textbox
colNum = ActiveSheet.Range(cellAddress).Column
'Get the formula as string from the cell named in textbox
originalText = ActiveSheet.Range(cellAddress).Formula
'************ START OF INDIRECT() FUNCTIONS PROCESSING ************'
'If this segment causes a problem, remove it
indirectNum = 0
state = 0
For i = 1 To Len(originalText)
char = Mid(originalText, i, 1)
If (char = "I" Or char = "i") And state = 0 Then
state = 1
ElseIf (char = "N" Or char = "n") And state = 1 Then
state = 2
ElseIf (char = "D" Or char = "d") And state = 2 Then
state = 3
ElseIf (char = "I" Or char = "i") And state = 3 Then
state = 4
ElseIf (char = "R" Or char = "r") And state = 4 Then
state = 5
ElseIf (char = "E" Or char = "e") And state = 5 Then
state = 6
ElseIf (char = "C" Or char = "c") And state = 6 Then
state = 7
ElseIf (char = "T" Or char = "t") And state = 7 Then
state = 8
indirectNum = indirectNum + 1
indirectLocation(indirectNum) = i - 7
ElseIf char = "(" And state > 7 Then
state = state + 1
ElseIf char = ")" And state > 8 Then
state = state - 1
If state = 8 Then
indirectLength(indirectNum) = i - indirectLocation(indirectNum) + 1
'Go back incase of INDIRECT statements inside INDIRECT statement.
i = indirectLocation(indirectNum) + 7
state = 0
End If
ElseIf state < 9 Then
state = 0
End If
Next
If indirectNum > 0 Then
For i = indirectNum To 1 Step -1
'Get the formula between the caps of the indirect function
indirectRef = Mid(originalText, indirectLocation(i), indirectLength(i))
'Evaluate the line formula betveen the caps of the indirect function
iE = Application.Evaluate(Mid(indirectRef, 10, indirectLength(i) - 10))
'Replace the Indirect function with the evaluation in the formula
originalText = Replace(originalText, indirectRef, iE)
Next
End If
'************ END OF INDIRECT() FUNCTIONS PROCESSING ************'
'Get the Address of the name of the measure from the column of names
originalText = ActiveSheet.Cells(rowNum, CN).Address & originalText
'************ START OF LISTING CELL ADDRESSES IN FORMULA *************'
'Consider each character in string that contains the formula. If it is an
'alphabetic letter or a "$" sign, then start making a record of an address. If
'the next is also alphabetic or a "$" sign continue makin record. If the next
'is a number, continue making the record, but accept only numeral characters
'from now on. If the character is something else, then stop making record. If
'the record is a full address when stopped, add it to the measure array,
'otherwise discard it.
state = 0
count = 0
For i = 1 To Len(originalText)
char = Mid(originalText, i, 1)
If IsAlpha(char) Or char = "$" Then
If state = 0 Then
aihio = char
If i > 1 Then
prevChar = Mid(originalText, i - 1, 1)
Else
'No previous character for the first letter. Here it's just A
prevChar = "A"
End If
state = 1
ElseIf state = 1 Then
aihio = aihio & char
ElseIf state = 2 Then
state = 0
measure(count) = aihio
count = count + 1
End If
ElseIf IsNumeric(char) And state > 0 Then
aihio = aihio & char
state = 2
'If formula ends in a cell address, the last character is a number.
If i = Len(originalText) Then
'If another sheet "!" or an array of cells ":" is referenced.
If prevChar = "!" Or prevChar = ":" Then
state = 0
Else
measure(count) = aihio
count = count + 1
End If
End If
ElseIf state = 2 Then
If prevChar = "!" Or prevChar = ":" Or char = ":" Then
state = 0
Else
state = 0
measure(count) = aihio
count = count + 1
End If
Else
state = 0
End If
Next
'************ END OF LISTING CELL ADDRESSES IN FORMULA *************'
'**** START OF REPLACING CELL ADDRESSES WITH THE NAMES OF THE MEASURES ****'
'For each name of measure in measure array
For i = 0 To count - 1
Set rE = ActiveSheet.Range(Replace(measure(i), "$", ""))
'If the cell of the measure is not empty
If Not IsEmpty(rE.Value) Then
'Get name of the measure
measureText = ActiveSheet.Cells(rE.Row, CN).Value
If measureText = "" Then
'Forgot to name the measure in the column of measure names?
measureText = "?"
Else
'For each character in name of the measure
For ii = 1 To Len(measureText)
'If the character in the name of the measure in the cell is subscript
If ActiveSheet.Cells(rE.Row, CN).Characters(ii, 1).Font.Subscript Then
'Add markings for subscript
measureText = Left(measureText, ii - 1) _
& "_(" & Right(measureText, Len(measureText) - ii + 1) & ")"
'Break the For loop when the objective is accomplished
Exit For
End If
Next
End If
'Replace addresses in the formula string with the name of the measure
originalText = Replace(originalText, measure(i), measureText)
End If
Next
'**** END OF REPLACING CELL ADDRESSES WITH THE NAMES OF THE MEASURES ****'
'The Identification of the calculation is added to the equation string
originalText = ActiveSheet.Cells(rowOfItemNames, colNum).Value _
& ":" & originalText
'Adds the start of the command to the command linestring
stringToRun = "MyEquation.DrawingObject.Text = " & outputString(originalText)
'Here the subroutine to write, execute and delete a new module is called.
ExecuteString stringToRun
Exit Sub
ErrorExit:
Exit Sub
ErrorHandler:
Debug.Print Err.Number & vbNewLine & Err.Description
Resume ErrorExit
End Sub
Function IsAlpha(s$) As Boolean
'This function returns true if the input character (String * 1) is alphabetic.
'Otherwise it retuns false. Copied from
'https://stackoverflow.com/questions/29633517/how-
'can-i-check-if-a-string-only-contains-letters
IsAlpha = Not s Like "*[!a-zA-Z]*"
End Function
Function outputString(inputString$) As String
On Error GoTo ErrorHandler
'If the text is taken from Cell as text, only the ASCII characters and
'markings are presented correctly. Others, symbols and such are presented
'by ?.'This function takes every character, weather ASCII or a Symbol, and
'gives it ChrW number. The output is a string of ChrW commands, that is
'readable by the Excel Equation Editor. This was copied from
'https://stackoverflow.com/questions/55478312/is-there-any-documentation-on-
'how-to-drive-the-office-equation-editor-through
Dim ChrIdx As Long
For ChrIdx = 1 To Len(inputString)
outputString = outputString & IIf(outputString <> vbNullString, " & ", "") _
& "ChrW(" & AscW(Mid$(inputString, ChrIdx, 1)) & ")"
Next ChrIdx
ErrorExit:
Exit Function
ErrorHandler:
Debug.Print Err.Number & vbNewLine & Err.Description
Resume ErrorExit
End Function
Sub ExecuteString(s As String)
On Error GoTo ErrorHandler
'This subroutine creates a new module, then runs the code from within, and
'then deletes the module after use. The Idea is, that because there are no
'direct vba commands to dynamically operate the Excel Equation Editor. The
'dynamic(using information in command that is not provided by the programmer)
'operation is made possible by automatically creating new module, writing
'new subroutines and the executing them. The codes here are copied and
'modified from the following sources:
'https://stackoverflow.com/questions/43216390/how-to-run-a-string-as-a-
'command-in-vba
'https://stackoverflow.com/questions/55478312/is-there-any-documentation-on-
'how-to-drive-the-office-equation-editor-through
'The Excel Equation Manager takes input as it is evoked from a list of ChrW
'commands. It is propably possible somehow to give the command as combination
'of ASCII tect and ChrW commands just to make the command string shorter.
Dim code As String
code = "Option Explicit" & vbCrLf
code = code & "Sub foo()" & vbCrLf
code = code & "On Error GoTo ErrorHandler" & vbCrLf
code = code & "Dim MyEquation As Shape" & vbCrLf
code = code & "Set MyEquation = ActiveSheet.Shapes(1)" & vbCrLf
code = code & "MakeEquationLinear MyEquation" & vbCrLf
code = code & "Application.EnableEvents = False" & vbCrLf
Dim i As Long
Dim ii As Long
'**** START OF SPLITTING THE COMMAND STRING TO LINES < 1024 CHAR ****'
i = IIf(1000 < Len(s), 1000, Len(s)) 'IIf() = Min(1000,Len(s))
ii = 1
While i <= Len(s)
If Mid(s, i, 1) = " " Then
code = code & Mid(s, ii, i - ii + 1) & "_" & vbCrLf
ii = i + 1
'If Min() was available in VBA: IIf() = Min(999,Len(s)-i-1)
i = i + IIf(999 < Len(s) - i - 1, 999, Len(s) - i - 1)
ElseIf i = Len(s) Then
code = code & Mid(s, ii, i - ii + 1) & vbCrLf
End If
i = i + 1
Wend
'**** END OF SPLITTING THE COMMAND STRING TO LINES < 1024 CHAR ****'
code = code & "Application.EnableEvents = True" & vbCrLf
code = code & "MakeEquationProfessional MyEquation" & vbCrLf
code = code & "ErrorExit:" & vbCrLf
code = code & " Application.EnableEvents = True" & vbCrLf
code = code & " Exit Sub" & vbCrLf
code = code & "ErrorHandler:" & vbCrLf
code = code & "Debug.Print Err.Number & vbNewLine & Err.Description" & vbCrLf
code = code & "Resume ErrorExit" & vbCrLf
code = code & "End Sub" & vbCrLf
Dim suba As String
suba = "Public Sub MakeEquationLinear(ByVal Equation As Shape)" & vbCrLf
suba = suba & "On Error GoTo ErrorHandler" & vbCrLf
suba = suba & "Dim OriginalSheet As Object" & vbCrLf
suba = suba & "If Equation.Parent.Name <> ActiveSheet.Name Then" & vbCrLf
suba = suba & " Set OriginalSheet = ActiveSheet" & vbCrLf
suba = suba & " Equation.Parent.Activate" & vbCrLf
suba = suba & "End If" & vbCrLf
suba = suba & "Application.EnableEvents = False" & vbCrLf
suba = suba & "Equation.Select" & vbCrLf
suba = suba & "Application.CommandBars.ExecuteMso ""EquationLinearFormat""" _
& vbCrLf
suba = suba & "Application.EnableEvents = True" & vbCrLf
suba = suba & "If Not OriginalSheet Is Nothing Then OriginalSheet.Activate" _
& vbCrLf
suba = suba & "ErrorExit:" & vbCrLf
suba = suba & " Application.EnableEvents = True" & vbCrLf
suba = suba & " Exit Sub" & vbCrLf
suba = suba & "ErrorHandler:" & vbCrLf
suba = suba & " Debug.Print Err.Number & vbNewLine & Err.Description" _
& vbCrLf
suba = suba & " Resume ErrorExit" & vbCrLf
suba = suba & "End Sub" & vbCrLf
Dim subb As String
subb = "Public Sub MakeEquationProfessional(ByVal Equation As Shape)" & vbCrLf
subb = subb & "On Error GoTo ErrorHandler" & vbCrLf
subb = subb & "Dim OriginalSheet As Object" & vbCrLf
subb = subb & "If Equation.Parent.Name <> ActiveSheet.Name Then" & vbCrLf
subb = subb & "Set OriginalSheet = ActiveSheet" & vbCrLf
subb = subb & "Equation.Parent.Activate" & vbCrLf
subb = subb & "End If" & vbCrLf
subb = subb & "Application.EnableEvents = False" & vbCrLf
subb = subb & "Equation.Select" & vbCrLf
subb = subb & "Application.CommandBars.ExecuteMso ""EquationProfessional""" _
& vbCrLf
subb = subb & "Application.EnableEvents = True" & vbCrLf
subb = subb & "If Not OriginalSheet Is Nothing Then OriginalSheet.Activate" _
& vbCrLf
subb = subb & "ErrorExit:" & vbCrLf
subb = subb & " Application.EnableEvents = True" & vbCrLf
subb = subb & " Exit Sub" & vbCrLf
subb = subb & "ErrorHandler:" & vbCrLf
subb = subb & " Debug.Print Err.Number & vbNewLine & Err.Description" _
& vbCrLf
subb = subb & " Resume ErrorExit" & vbCrLf
subb = subb & "End Sub" & vbCrLf
Dim tempVBC As Object
Set tempVBC = ActiveWorkbook.VBProject.VBComponents.Add(1)
tempVBC.CodeModule.AddFromString code
tempVBC.CodeModule.AddFromString suba
tempVBC.CodeModule.AddFromString subb
Application.Run tempVBC.Name & ".foo"
ThisWorkbook.VBProject.VBComponents.Remove tempVBC
ErrorExit:
Exit Sub
ErrorHandler:
Debug.Print Err.Number & vbNewLine & Err.Description
Resume ErrorExit
End Sub
In the code you can edit the following lines to match the column and row on your sheet:
columnOfMeasureNames = "C"
rowOfItemNames = 8
Result:
