修改所有图表 2

Question

进一步说 Amending all Charts

• @CDP1802 非常友好地解决了问题 - 再次感谢 -

我傻了。 . . 我还需要扩展图表上出现的线条，即

Private Sub Workbook_Open()
Option Explicit
Dim ws As Worksheet, cht As ChartObject, n As Integer, dt As Date
Dim myLastRow As Integer, myRow As Integer
    
Sheets("Record").Select

' Go to last entry
myLastRow = ActiveCell.SpecialCells(xlLastCell).Row
myLastRow = Range("H" & myLastRow).End(xlUp).Row
Range("D" & myLastRow).Select   ' Don't ask !
    
' Extend Column A so that the last entry is a week from today.
'  Also extend predictions

myRow = myLastRow
Do Until Range("A" & myRow) >= Now() + 7
    myRow = myRow + 1
    Range("A" & myRow) = Range("A" & myRow - 1) + 1
    If myRow > myLastRow + 1 Then
        Range("B" & myRow & ":G" & myRow) = Range("B" & myRow - 1 & ":G" & myRow - 1)
    End If
Loop


dt = Date + 7

 For Each ws In ThisWorkbook.Sheets
    For Each cht In ws.ChartObjects
          cht.Chart.Axes(xlCategory).MaximumScale = dt

          For every Line in the Chart
            If the X-axis is Sheet("Record").Column A Then 
                 Extend the line (Column A and its own Column) down to myRow
            End If
          Next Line
    
    Next
 Next

End Sub

Answer 1

试试这个。它通过修改每个系列的公式 R1C1 来工作。例如

如果formulaR1C1 = "=SERIES("Weight",,Record!R38C1:R2281C1,Record!R38C8:R2281C8,1)" 那么

ar = Split(ser.FormulaR1C1, "R")

将创建一个字符串数组 ("=SE","IES("Weight",,","ecord!","38C1:","2281C1,","ecord!","38C8:","2281C8,1").

最后一个元素ar(ubound(ar)) 是2281C8,1。在C 上拆分，第一个元素是2281。将该行号替换为带有Replace(ser.FormulaR1C1, ":R" & r & "C", ":R" & myRow & "C")的新行号

如果出现问题，将在与工作簿相同的目录中创建一个名为 debug.log 的文件。

Option Explicit

Private Sub Workbook_Open()

    Dim ws As Worksheet, cht As ChartObject, n As Integer, dt As Date
    Dim myLastRow As Integer, myRow As Integer
        
    Sheets("Record").Select
    
    ' Go to last entry
    myLastRow = ActiveCell.SpecialCells(xlLastCell).Row
    myLastRow = Range("H" & myLastRow).End(xlUp).Row
    Range("D" & myLastRow).Select   ' Don't ask !
        
    ' Extend Column A so that the last entry is a week from today.
    '  Also extend predictions
    
    myRow = myLastRow
    Do Until Range("A" & myRow) >= Now() + 7
        myRow = myRow + 1
        Range("A" & myRow) = Range("A" & myRow - 1) + 1
        If myRow > myLastRow + 1 Then
            Range("B" & myRow & ":G" & myRow).Value2 = Range("B" & myRow - 1 & ":G" & myRow - 1).Value2
        End If
    Loop
     
    dt = Date + 7
    
    ' log file for debugging
    Dim fso, ts
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.createTextFile("debug.log")

    Dim ser As Series, ar, r As Long
    Dim sOld As String, sNew As String
    For Each ws In ThisWorkbook.Sheets
        For Each cht In ws.ChartObjects
            cht.Chart.Axes(xlCategory).MaximumScale = dt
            ' For every line in the Chart
            ' extend the data range to myRow
            For Each ser In cht.Chart.SeriesCollection
                ' determine existing last row
                sOld = ser.FormulaR1C1
                ts.writeLine ser.Name & vbTab & ser.ChartType & vbTab & ser.Type
                ts.writeLine "Old: " & sOld
                ar = Split(ser.FormulaR1C1, "R")
                r = Split(ar(UBound(ar)), "C")(0)
                ts.writeLine UBound(ar) & vbTab & r & vbTab & myRow
                
                sNew = Replace(ser.FormulaR1C1, ":R" & r & "C", ":R" & myRow & "C")
                ts.writeLine "New: " & sNew & vbCrLf

                ' update series
                ser.FormulaR1C1 = sNew
              Next
        Next
     Next
     ts.Close
     MsgBox "Extended from row " & r & " to row " & myRow

End Sub