将系列趋势线方程获取到形状文本框

Question

我正在尝试将趋势线方程从图表中的第一个系列获取到放置在工作表其他位置的形状文本框 - 但是，我只能在单步执行代码时让文本框正确填充逐行 - 在运行时它没有效果：

For Each chtObj In ActiveSheet.ChartObjects

    Set cht = chtObj.Chart

    For Each srs In chtObj.Chart.SeriesCollection
        srs.Trendlines(1).DisplayEquation = True 'Display the labels to get the value
        ThisWorkbook.Worksheets("MyDataSheet").Shapes(slopetextboxes(k)).TextFrame.Characters.Text = srs.Trendlines(1).DataLabel.Text
        srs.Trendlines(1).DisplayEquation = False 'Turn it back off
        Exit For
    Next srs

    k = k + 1 ' for the slope textboxes

Next chtObj

请注意，slopetextboxes 是一个包含约 6 个形状文本框名称的数组。

据我所知，没有办法在不停止显示的情况下获取趋势线数据标签。我已经尝试先将它存储在一个字符串中，DoEvents，然后重新打开Application.ScreenUpdating，一切都无济于事。我被难住了。

编辑：看来，通过将DoEvents 放在.DisplayEquation = True 之后，我可以正确填充一些我的形状，但不是全部。似乎仍然是某种运行时问题。

BOUNTY EDIT：我已经开始用公式抓取数据本身的斜坡，但我仍然不明白为什么我不能抓取图表的@ 987654327@ 在运行时。我可以在单步执行时抓住它，而不是在运行时。它似乎只是采用 PREVIOUS 系列斜率并将其放置在形状中（或单元格，甚至目的地在哪里都没有关系）。 DoEvents 放置在不同的位置会产生不同的结果，所以一定是发生了什么。

Answer 1

更新了对错误的更好理解。这在 excel 2016 中对我有用，对源数据（以及斜率）进行了多次更改

我试过 myChart.refresh - 没用。我尝试删除然后重新添加整个趋势线，也没有用。

这适用于除第一种情况以外的所有情况。第一种情况需要打两次。与 .select 相同

如果您在将趋势线的文本分配给文本框后尝试删除趋势线，这将不起作用

Option Explicit
Sub main()
Dim ws                                  As Worksheet
Dim txtbox                              As OLEObject
Dim chartObject                         As chartObject
Dim myChart                             As chart
Dim myChartSeriesCol                    As SeriesCollection
Dim myChartSeries                       As Series
Dim myChartTrendLines                   As Trendlines
Dim myTrendLine                         As Trendline

    Set ws = Sheets("MyDataSheet")
    Set txtbox = ws.OLEObjects("TextBox1")

    For Each chartObject In ws.ChartObjects
        Set myChart = chartObject.chart
        Set myChartSeriesCol = myChart.SeriesCollection
        Set myChartSeries = myChartSeriesCol(1)
        Set myChartTrendLines = myChartSeries.Trendlines

        With myChartTrendLines
            If .Count = 0 Then
                .Add
            End If
        End With

        Set myTrendLine = myChartTrendLines.Item(1)

        With myTrendLine
            .DisplayEquation = True
            txtbox.Object.Text = .DataLabel.Text
        End With
     Next chartObject
End Sub

Answer 2

这是我的代码，只要按 F5 就可以正常工作：

基本上，我将文本存储在一个集合中，然后遍历所有文本框以将文本添加到文本框中。如果这不是您所要求的，那么我希望这对您有所帮助。

Sub getEqus()
    Dim ws As Worksheet
    Dim cht As Chart
    Dim srs As Variant
    Dim k As Long
    Dim i As Long
    Dim equs As New Collection
    Dim shp As Shape
    Dim slopetextboxes As New Collection

    Set ws = Excel.Application.ThisWorkbook.Worksheets(1)

    'part of the problem seemed to be how you were defining your shape objects
    slopetextboxes.Add ws.Shapes.Range("TextBox 4")
    slopetextboxes.Add ws.Shapes.Range("TextBox 5")

    For Each chtObj In ActiveSheet.ChartObjects
        Set cht = chtObj.Chart

        For Each srs In chtObj.Chart.SeriesCollection
            srs.Trendlines(1).DisplayEquation = True 'Display the labels to get the value

            equs.Add srs.Trendlines(1).DataLabel.Text

            srs.Trendlines(1).DisplayEquation = False 'Turn it back off
        Next srs

    Next chtObj


    For i = 1 To slopetextboxes.Count

        'test output i was trying
        ws.Cells(i + 1, 7).Value = equs(i)
        slopetextboxes(i).TextFrame.Characters.Text = equs(i)
    Next
End Sub

当我按下按钮时输出的样子

祝你好运！

Answer 3

这对我有用 - 我遍历 Sheet1 上的多个图表，切换 DisplayEquation，然后将方程写入不同工作表上的文本框/形状。我使用了TextFrame2.TextRange，但TextFrame 也可以，如果您愿意的话。我同时写了一个常规文本框和一个形状，这可能是多余的，因为两者的语法相同。

这从第一个 Series 得到趋势线方程 - 听起来您不想遍历 SeriesCollection 中的所有 Series。

Sub ExtractEquations()
    Dim chtObj As ChartObject
    Dim slopeTextBoxes() As Variant
    Dim slopeShapes() As Variant
    Dim i As Integer

    slopeTextBoxes = Array("TextBox 1", "TextBox 2", "TextBox 3")
    slopeShapes = Array("Rectangle 6", "Rectangle 7", "Rectangle 8")

    For Each chtObj In ThisWorkbook.Sheets("Sheet1").ChartObjects

        With chtObj.Chart.SeriesCollection(1).Trendlines(1)
            .DisplayEquation = True
            ThisWorkbook.Sheets("MyDataSheet").Shapes(slopeTextBoxes(i)).TextFrame2.TextRange.Characters.Text = .DataLabel.Text
            ThisWorkbook.Sheets("MyDataSheet").Shapes(slopeShapes(i)).TextFrame2.TextRange.Characters.Text = .DataLabel.Text
            .DisplayEquation = False
            i = i + 1
        End With
    Next chtObj
End Sub

Answer 4

我已将此作为一个错误写下来 - BrakNicku 发现了唯一的解决方法，即在阅读其 Text 属性之前，Select 和 DataLabel：

srs.Trendlines(1).DataLabel.Select

不是一个充分的解决方案（因为这可能会在运行时导致一些问题），但唯一可行的方法。

Answer 5

我在运行下面的代码时遇到了类似的问题，我的解决方案是在设置趋势线和查询 DataLabel 之间运行 Application.ScreenUpdating = True。请注意，屏幕更新已启用。

    'Set trendline to the formal y = Ae^Bx
    NewTrendline.Type = xlExponential
    'Display the equation on the chart
    NewTrendline.DisplayEquation = True
    'Add the R^2 value to the chart
    NewTrendline.DisplayRSquared = True
    'Increse number of decimal places
    NewTrendline.DataLabel.NumberFormat = "#,##0.000000000000000"
    'Enable screen updating for the change in format to take effect otherwise FittedEquation = ""
    Application.ScreenUpdating = True
    'Get the text of the displated equation
    FittedEquation = NewTrendline.DataLabel.Text

Answer 6

如果它在您逐步执行时有效，但在运行时无效，那么这是时间问题以及 Excel 在步骤之间所做的事情。当您逐步完成时，有时间弄清楚并更新屏幕。

仅供参考，Application.Screenupdating = False 在步进时不起作用 通过代码。无论代码暂停，它都会被设置回True。

你什么时候给它一个机会来实际做数学和计算方程？答案是，你没有；因此为什么你会得到前面的公式。

如果你添加一个简单的Application.Calculate（在正确的位置），我想你会发现它工作得很好。

此外，Excel 为什么要浪费时间将文本更新为不可见的对象？答案是，不应该，也不应该。

为了尽量减少您希望 Excel 计算的次数，我建议创建两个循环。

1. 第一个，遍历每个图表并显示方程式
2. 然后强制 Excel 计算值
3. 随后是另一个循环以获取值并再次隐藏方程式。

---

' Display the labels on all the Charts
For Each chtObj In ActiveSheet.ChartObjects
    Set cht = chtObj.Chart
    For Each srs In chtObj.Chart.SeriesCollection
        srs.Trendlines(1).DisplayEquation = True 'Display the labels to get the value
        ' I take issue with the next line
        ' Why are you creating a loop, just for the first series?
        ' I hope this is just left over from a real If condition that wan't included for simplicity
        Exit For
    Next srs
Next chtObj

Application.ScreenUpdating = True
Application.Calculate
Application.ScreenUpdating = False

' Get the Equation and hide the equations on the chart
For Each chtObj In ActiveSheet.ChartObjects
    Set cht = chtObj.Chart
    For Each srs In chtObj.Chart.SeriesCollection
        ThisWorkbook.Worksheets("MyDataSheet").Shapes(slopetextboxes(k)).TextFrame.Characters.Text = srs.Trendlines(1).DataLabel.Text
        srs.Trendlines(1).DisplayEquation = False 'Turn it back off
        Exit For
    Next srs
    k = k + 1 ' for the slope textboxes
Next chtObj
Application.ScreenUpdating = True

更新：

我根据您对问题的描述添加了一个示例文件。您可以在 ActiveX 组合框中选择 4 个不同的选项，将值复制到图表的 Y 值。它显示了下面的趋势线方程，基于公式并通过将图表中的值复制到文本框形状中。

也许 2016 年有所不同，但它在 2013 年完美运行。试试看...

Shape Text Box Example.xlsm