如何通过VBA获取Excel内置Evaluate Formula步骤并粘贴到工作表？

核心结论 #

Excel没有提供直接调用内置「公式求值」工具的官方API，无法直接读取该工具的分步求值数据，但可以通过以下两种方案实现类似需求：

方案1：模拟分步求值（推荐） #

通过解析公式的子表达式，调用Excel内置的求值引擎逐个计算，记录每一步的结果，完全替代「公式求值」工具的分步展示功能，还能自定义输出格式。

示例VBA代码

Sub GetFormulaEvaluationSteps()
    Dim targetCell As Range
    Dim formulaStr As String
    Dim subExprs As Variant
    Dim wsOutput As Worksheet
    Dim i As Integer
    
    ' 选中要分析的公式单元格
    Set targetCell = Selection
    If targetCell.HasFormula = False Then
        MsgBox "选中单元格无公式"
        Exit Sub
    End If
    formulaStr = targetCell.Formula
    
    ' 创建输出工作表
    Set wsOutput = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    wsOutput.Name = "公式求值步骤"
    
    ' 解析公式子表达式（这里简化处理，复杂公式需更完善的解析逻辑）
    subExprs = SplitFormulaIntoSubExpressions(formulaStr)
    
    ' 写入表头
    wsOutput.Range("A1").Value = "步骤序号"
    wsOutput.Range("B1").Value = "子表达式"
    wsOutput.Range("C1").Value = "求值结果"
    wsOutput.Rows(1).Font.Bold = True
    
    ' 逐个求值并写入结果
    For i = LBound(subExprs) To UBound(subExprs)
        wsOutput.Range("A" & i + 2).Value = i + 1
        wsOutput.Range("B" & i + 2).Value = subExprs(i)
        On Error Resume Next
        Dim evalResult As Variant
        evalResult = Application.Evaluate(subExprs(i))
        If Err.Number = 0 Then
            ' 处理数组结果
            If IsArray(evalResult) Then
                wsOutput.Range("C" & i + 2).Resize(UBound(evalResult, 1), UBound(evalResult, 2)).Value = evalResult
            Else
                wsOutput.Range("C" & i + 2).Value = evalResult
            End If
        Else
            wsOutput.Range("C" & i + 2).Value = "求值错误"
            Err.Clear
        End If
        On Error GoTo 0
    Next i
End Sub

' 简化的公式拆分函数（需根据需求完善）
Function SplitFormulaIntoSubExpressions(formula As String) As Variant
    ' 示例：拆分括号内的子表达式，实际需处理运算符、函数参数等
    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = "\(([^()]+)\)"
    regex.Global = True
    Dim matches As Object
    Set matches = regex.Execute(formula)
    
    Dim result() As String
    ReDim result(0 To matches.Count)
    result(0) = formula
    For i = 1 To matches.Count
        result(i) = matches(i - 1).Value
    Next i
    SplitFormulaIntoSubExpressions = result
End Function

注意事项

• 上述代码的公式拆分逻辑是简化版，复杂公式（嵌套函数、数组运算符等）需要更完善的解析逻辑，可参考Excel公式的语法规则实现更精准的拆分
• 数组公式求值后会得到数组对象，代码中已处理将数组展开到单元格区域的逻辑，无需手动滚动查看

方案2：捕获「公式求值」窗口截图 #

如果需要完全复刻内置工具的界面内容，可以通过VBA调用Windows API捕获窗口截图，再粘贴到工作表。但这种方法依赖窗口句柄，不同Excel版本可能存在兼容性问题，仅作为备选方案。

示例VBA代码片段（需添加API声明）

' 在模块顶部添加API声明
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function PrintWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal hdcBlt As LongPtr, ByVal nFlags As Long) As Boolean
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hdc As LongPtr) As Long

Sub CaptureEvaluateWindow()
    Dim hwndEvaluate As LongPtr
    Dim wsOutput As Worksheet
    Dim pic As Shape
    
    ' 查找公式求值窗口句柄（窗口标题可能因Excel语言版本变化）
    hwndEvaluate = FindWindow(vbNullString, "公式求值")
    If hwndEvaluate = 0 Then
        MsgBox "请先打开「公式求值」窗口"
        Exit Sub
    End If
    
    ' 创建输出工作表
    Set wsOutput = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    wsOutput.Name = "求值窗口截图"
    
    ' 捕获窗口并粘贴
    Dim hdc As LongPtr
    hdc = GetDC(hwndEvaluate)
    PrintWindow hwndEvaluate, hdc, 0
    ReleaseDC hwndEvaluate, hdc
    
    ' 将截图粘贴到工作表
    wsOutput.Paste
    Set pic = wsOutput.Shapes(wsOutput.Shapes.Count)
    pic.Top = 10
    pic.Left = 10
End Sub

补充说明 #

你提到的工具仅能拆分公式结构，无法获取实际求值步骤，原因是它们没有调用Excel的求值引擎计算每一步的结果。而上述方案1直接利用Application.Evaluate调用Excel内置引擎，能得到和「公式求值」工具完全一致的分步结果，且支持自定义输出格式，解决窗口过小、滚动不便的问题。

内容的提问来源于stack exchange，提问作者Rasec Malkic