Excel VBA函数：将计算结果转换为公式字符串

创作时间:

作者:

@小白创作中心

Excel VBA函数：将计算结果转换为公式字符串

引用

CSDN

https://blog.csdn.net/weixin_37942087/article/details/142920363

在工程设计领域，Excel是进行复杂计算的重要工具。为了方便将计算结果以公式形式展示，一位结构设计工程师开发了一个实用的VBA函数，能够将单元格的计算结果转换为完整的公式字符串，并支持位置引用和自定义名称引用。

背景需求

在工程设计工作中，Excel被广泛用于各种计算任务。为了便于记录和展示计算过程，有时需要将单元格的计算结果转换为公式字符串显示。具体需求包括：

将单元格的计算结果转换为公式字符串
支持位置引用（如A1、B2等）
支持自定义名称引用
如果最外层使用了ROUND函数，需要隐去该函数

函数实现

下面是一个满足上述需求的VBA函数实现：

Public Function xqzde(ans As Range) As String
    ' de for display equation
    Dim formulastring As String
    Dim innerformula As String
    ' 读取单元格(公式形式)
    formulastring = ans.Formula
    '1. 替换常用自定函数π以及绝对位置引用符号
    formulastring = Replace(formulastring, "$", "")
    formulastring = Replace(formulastring, "Pi()", "3.14")
    formulastring = Replace(formulastring, "pi()", "3.14")
    formulastring = Replace(formulastring, "PI()", "3.14")
    '2. 识别外层round函数，有则删除
    Dim ws As Worksheet
    Set ws = ActiveSheet
    Set regex = CreateObject("VBScript.RegExp")
    regex.Global = True    '全局匹配
    regex.IgnoreCase = True    '忽略大小写
    regex.Pattern = "round\((.*)\)$"
    Set matches = regex.Execute(formulastring)
    If matches.Count > 0 Then
        innerformula = matches(0).SubMatches(0)
        commaposition = InStr(innerformula, ",")
        innerformula = "=" & Left(innerformula, commaposition - 1)
    Else
        innerformula = formulastring ' 如果没有找到 round 函数，返回原始公式
    End If
    formulastring = innerformula
    '3. 识别公式中的自定义名称并进行替换
    Dim nm As Name
    Dim namesArray() As Variant
    Dim prefixpos As Integer
    Dim cusname As String
    Dim cellvalue As String
    Dim temp As Variant
    Dim isSorted As Boolean
    ReDim namesArray(1 To ws.Names.Count, 1 To 2)
    i = 1
    ' 3.1  遍历名称管理器中的所有名称
    For Each nm In ws.Names
        If nm.Parent.Name = ws.Name Then
            namesArray(i, 1) = nm.Name
            namesArray(i, 2) = Len(nm.Name)
            i = i + 1
        End If
    Next nm
    ReDim Preserve namesArray(1 To i - 1, 1 To 2)
    ' 使用冒泡排序算法按名称长度排序（先长后短）
    For j = LBound(namesArray, 1) To UBound(namesArray, 1) - 1
        isSorted = True
        For i = LBound(namesArray, 1) To UBound(namesArray, 1) - 1
            If namesArray(i, 2) < namesArray(i + 1, 2) Then
                temp = namesArray(i, 1)
                namesArray(i, 1) = namesArray(i + 1, 1)
                namesArray(i + 1, 1) = temp
                temp = namesArray(i, 2)
                namesArray(i, 2) = namesArray(i + 1, 2)
                namesArray(i + 1, 2) = temp
                isSorted = False
            End If
        Next i
        If isSorted Then Exit For
    Next j
    ' 处理排序后的名称
    For i = LBound(namesArray, 1) To UBound(namesArray, 1)
        Set nm = ThisWorkbook.Names(namesArray(i, 1))
        If nm.Parent.Name = ws.Name Then
            prefixpos = InStr(nm.Name, "!")
            If prefixpos > 0 Then
                cusname = Mid(nm.Name, prefixpos + 1)
            Else
                cusname = nm.Name
            End If
            cellvalue = CStr(Range(nm.RefersTo).Value)
            formulastring = Replace(formulastring, cusname, cellvalue)
        End If
    Next i
    '4. 识别公式中的位置引用并进行替换
    regex.Pattern = "([A-Z]+\d+)"
    Set matches = regex.Execute(formulastring)
    foundformula = formulastring
    For i = 0 To matches.Count - 1
        Set cellRef = ws.Range(matches(i).SubMatches(0))
        If IsNumeric(cellRef.Value) Then
            cellvalue = CStr(cellRef.Value)
        Else
            cellvalue = """" & cellRef.Value & """"
        End If
        foundformula = Replace(foundformula, matches(i).Value, cellvalue)
    Next i
    xqzde = foundformula & "="
End Function