Excel VBA - 将动态范围传递给图表

问题描述

我正在编写一个代码来检查工作表的状态，当它发生变化时，它会自动在上面运行一些计算。但我也希望有一个图表，该图表将使用该工作表中的新数据集进行刷新。

为此，我使用了 Worksheet_Change 函数，它工作正常。它调用带有计算的子程序并调用包含图表修改代码的子程序。它们按计划运行，只有一个例外。传递给 Chrt1 子项（负责图表功能）的范围在第一次被调用后不会在图表上更新。

我知道这可以通过 Excel 内置表格函数来克服，但无论如何我想编写这个简单的例程。

Worksheet_Change 函数如下所示：

Sub Worksheet_Change(ByVal Target As Range)
   
Application.EnableEvents = False
      
AutochangeTest

Application.EnableEvents = True

End Sub

主要模块代码如下：

Sub Autochangetest()

Dim s1 As Worksheet,s2 As Worksheet
Dim i As Integer,j As Integer,lrow As Integer,lrow2 As Integer

Set s1 = Sheets("Arkusz3")

On Error GoTo Err1

lrow = s1.Cells(s1.Rows.Count,1).End(xlUp).Row

For i = 1 To lrow
    s1.Cells(i,2) = s1.Cells(i,1) * 2
Next

Call Chrt1(Range(s1.Cells(1,1),s1.Cells(lrow,2)),s1)

Err1:

If Not IsNumeric(s1.Cells(i,1)) Then
    s1.Cells(i,1).Activate
End If

End Sub

Sub Chrt1(r1 As Range,s1 As Worksheet)

Dim c1 As Shape
Dim s As Worksheet
Dim cht As ChartObject
Dim i As Integer

i = 0
Set r = r1
Set s = s1

For Each cht In s.ChartObjects
    i = i + 1
Next
    
If i = 0 Then
    Set c1 = s.Shapes.AddChart
End If

c1.Chart.SetSourceData (r)

End Sub

任何提示将不胜感激。

解决方法

以下代码中的一些建议：

Sub AutoChangeTest()

    Dim ws As Worksheet 'avoid variable names with 1/l - too unclear
    Dim i As Long,lrow As Long 'always use long over integer
    
    Set ws = ThisWorkbook.Worksheets("Arkusz3")
    
    lrow = ws.Cells(ws.Rows.Count,1).End(xlUp).row
    
    On Error GoTo exitHere
    Application.EnableEvents = False 'don't re-trigger this sub...
    For i = 1 To lrow
        With ws.Cells(i,1)
            'easier to test than to trap an error if non-numeric
            If IsNumeric(.Value) Then
                ws.Cells(i,2) = .Value * 2
            Else
                ws.Select
                .Select
                MsgBox "Non-numeric value found!"
                GoTo exitHere 'acceptable use of Goto I think
            End If
        End With
    Next
    
    'don't think you need a separate method for this...
    If ws.ChartObjects.Count = 0 Then ws.Shapes.AddChart 'no need to loop for a count
    'assuming there will only be one chart...
    ws.ChartObjects(1).Chart.SetSourceData ws.Range(ws.Cells(1,1),ws.Cells(lrow,2))
    
exitHere:
    If Err.Number <> 0 Then Debug.Print Err.Description
    Application.EnableEvents = True
    
End Sub

在你的 Chrt1 程序中，这个位

For Each cht In s.ChartObjects
    i = i + 1
Next
    
If i = 0 Then
    Set c1 = s.Shapes.AddChart
End If

可以替换为以下内容：

If s.ChartObjects.Count = 0 Then
    Set c1 = s.Shapes.AddChart
End If

但是如果您不必添加图表，c1 是什么？您尚未定义它，On Error 表示您永远不会发现它已损坏。

假设您希望最后一个图表对象成为更改的对象：

If s.ChartObjects.Count = 0 Then
    Set c1 = s.Shapes.AddChart
Else
    Set c1 = s.ChartObjects(s.ChartObjects.Count)
End If

并且您应该将 c1 声明为 ChartObject。

最后，删除此行中 r 周围的括号：

c1.Chart.SetSourceData r

谢谢大家的支持。工作的基本代码如下所示。它不是最好看的，但它可以胜任。

Sub Chrt1(r1 As Range,s1 As Worksheet)

Dim c1 As Shape
Dim s As Worksheet
Dim cht As ChartObject
Dim i As Integer

i = 0
Set r = r1
Set s = s1

For Each cht In s.ChartObjects
    i = i + 1
Next
    
If i = 0 Then
    Set c1 = s.Shapes.AddChart
End If


Set cht = s.ChartObjects(1)


cht.Chart.SetSourceData Source:=r


End Sub

excel excel excel-charts vba