Question

我需要此宏才能从2个（或更多）单元格引用中生成2个（或更多）数据列。当前，它仅从一个单元格引用中进行一个数据系列。该脚本会生成一个表，并每秒用一个新的数据条目更新表，然后使用表数据更新图表。单元格值实时更改。

这应该是一个简单的修复程序，但是我无法弄清楚代码。我不在同盟中。任何帮助都是极好的。也许有人可以重构它，或者至少给我一些有关我应该做什么的提示。

Option Explicit
'Update the values between the quotes here:
Private Const sChartWSName = "Chart"
Private Const sSourceWSName = "Tickers"
Private Const sTableName = "tblValues"
Public RunTime As Double
Private Sub Chart_Setup()
'Create the structure needed to preserve and chart data
    Dim wsChart As Worksheet
    Dim lstObject As ListObject
    Dim cht As Chart
    Dim shp As Button
    'Create sheet if necessary
    Set wsChart = Worksheets.Add
    wsChart.name = sChartWSName
    'Set up listobject to hold data
    With wsChart
        .Range("A1").value = "Time"
        .Range("B1").value = "Value"
        Set lstObject = .ListObjects.Add( _
                        SourceType:=xlSrcRange, _
                        Source:=.Range("A1:B1"), _
                        xllistobjecthasheaders:=xlYes)
        lstObject.name = sTableName
        .Range("A2").NumberFormat = "h:mm:ss"
        .columns("A:A").ColumnWidth = 25
        .Select
    End With
    'Create the chart
    With ActiveSheet
        .Shapes.AddChart.Select
        Set cht = ActiveChart
        With cht
            .ChartType = xlLine
            .SetSourceData Source:=Range(sTableName)
            .PlotBy = xlColumns
            .Legend.Delete
            .Axes(xlCategory).CategoryType = xlCategoryScale
            With .SeriesCollection(1).Format.Line
                .Visible = msoTrue
                .Weight = 1.25
            End With
        End With
    End With
    'Add buttons to start/stop the routine
    Set shp = ActiveSheet.Buttons.Add(242.25, 0, 83.75, 33.75)
    With shp
        .OnAction = "Chart_Initialize"
        .Characters.Text = "Restart Plotting"
    End With
    Set shp = ActiveSheet.Buttons.Add(326.25, 0, 83.75, 33.75)
    With shp
        .OnAction = "Chart_Stop"
        .Characters.Text = "Stop Plotting"
    End With
End Sub
Public Sub Chart_Initialize()
'Initialize the routine
    Dim wsTarget As Worksheet
    Dim lstObject As ListObject
    'Make sure worksheet exists
    On Error Resume Next
    Set wsTarget = Worksheets(sChartWSName)
    If Err.Number <> 0 Then
        Call Chart_Setup
        Set wsTarget = Worksheets(sChartWSName)
    End If
    On Error GoTo 0
    'Check if chart data exists
    With Worksheets(sChartWSName)
        Set lstObject = .ListObjects(sTableName)
        If lstObject.ListRows.Count > 0 Then
            Select Case MsgBox("You already have data.  Do you want to clear it and start fresh?", vbYesNoCancel, "Clear out old data?")
                Case Is = vbYes
                    'User wants to clear the data
                    lstObject.DataBodyRange.Delete
                Case Is = vbCancel
                    'User cancelled so exit routine
                    Exit Sub
                Case Is = vbNo
                    'User just wants to append to existing table
            End Select
        End If
        'Begin appending
        Call Chart_AppendData
    End With
End Sub
Private Sub Chart_AppendData()
'Append data to the chart table
    Dim lstObject As ListObject
    Dim lRow As Long
    With Worksheets(sChartWSName)
        Set lstObject = .ListObjects(sTableName)
        If lstObject.ListRows.Count = 0 Then
            lRow = .Range("A1").End(xlDown).row
        End If
        If lRow = 0 Then
            lRow = .Range("A" & .rows.Count).End(xlUp).offset(1, 0).row
        End If
        .Range("A" & lRow).value = CDate(Now)
        .Range("B" & lRow).value = Worksheets(sSourceWSName).Range("M4").value
    End With
    RunTime = Now + TimeValue("00:00:01")
    Application.OnTime RunTime, "Chart_AppendData"
End Sub
Public Sub Chart_Stop()
'Stop capturing data
    On Error Resume Next
    Application.OnTime EarliestTime:=RunTime, Procedure:="Chart_AppendData", Schedule:=False
End Sub

这是“ ThisWorkbook”的片段

Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Stop workbook refreshing
Call Chart_Stop
End Sub

Answer 1

我希望这会有所帮助。

    Option Explicit
'Update the values between the quotes here:
Private Const sChartWSName = "Chart"
Private Const sSourceWSName = "Tickers"
Private Const sTableName = "tblValues"
Public RunTime As Double
Private Sub Chart_Setup()
'Create the structure needed to preserve and chart data
    Dim wsChart As Worksheet
    Dim lstObject As ListObject
    Dim cht As Chart
    Dim shp As Button
    'Create sheet if necessary
    Set wsChart = Worksheets.Add
    wsChart.Name = sChartWSName
    'Set up listobject to hold data
    With wsChart
        .Range("A1").Value = "Time"
        .Range("B1").Value = "Value1"
'**** I added C! and changed "Value" to "Value1" and "Value2"
        .Range("C1").Value = "Value2"
'**** I increased the range of the chart below to C1
        Set lstObject = .ListObjects.Add( _
                        SourceType:=xlSrcRange, _
                        Source:=.Range("A1:C1"), _
                        xllistobjecthasheaders:=xlYes)
        lstObject.Name = sTableName
        .Range("A2").NumberFormat = "h:mm:ss"
        .Columns("A:A").ColumnWidth = 25
        .Select
    End With
    'Create the chart
    With ActiveSheet
        .Shapes.AddChart.Select
        Set cht = ActiveChart
        With cht
            .ChartType = xlLine
            .SetSourceData Source:=Range(sTableName)
            .PlotBy = xlColumns
            .Legend.Delete
            .Axes(xlCategory).CategoryType = xlCategoryScale
            With .SeriesCollection(1).Format.Line
                .Visible = msoTrue
                .Weight = 1.25
            End With
        End With
    End With
    'Add buttons to start/stop the routine
    Set shp = ActiveSheet.Buttons.Add(242.25, 0, 83.75, 33.75)
    With shp
        .OnAction = "Chart_Initialize"
        .Characters.Text = "Restart Plotting"
    End With
    Set shp = ActiveSheet.Buttons.Add(326.25, 0, 83.75, 33.75)
    With shp
        .OnAction = "Chart_Stop"
        .Characters.Text = "Stop Plotting"
    End With
End Sub
Public Sub Chart_Initialize()
'Initialize the routine
    Dim wsTarget As Worksheet
    Dim lstObject As ListObject
    'Make sure worksheet exists
    On Error Resume Next
    Set wsTarget = Worksheets(sChartWSName)
    If Err.Number <> 0 Then
        Call Chart_Setup
        Set wsTarget = Worksheets(sChartWSName)
    End If
    On Error GoTo 0
    'Check if chart data exists
    With Worksheets(sChartWSName)
        Set lstObject = .ListObjects(sTableName)
        If lstObject.ListRows.Count > 0 Then
            Select Case MsgBox("You already have data.  Do you want to clear it and start fresh?", vbYesNoCancel, "Clear out old data?")
                Case Is = vbYes
                    'User wants to clear the data
                    lstObject.DataBodyRange.Delete
                Case Is = vbCancel
                    'User cancelled so exit routine
                    Exit Sub
                Case Is = vbNo
                    'User just wants to append to existing table
            End Select
        End If
        'Begin appending
        Call Chart_AppendData
    End With
End Sub
Public Sub Chart_AppendData()
'Append data to the chart table
    Dim lstObject As ListObject
    Dim lRow As Long
    With Worksheets(sChartWSName)
        Set lstObject = .ListObjects(sTableName)
        If lstObject.ListRows.Count = 0 Then
            lRow = .Range("A1").End(xlDown).Row
        End If
        If lRow = 0 Then
            lRow = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row
        End If
        .Range("A" & lRow).Value = CDate(Now)
        .Range("B" & lRow).Value = 4
        .Range("C" & lRow).Value = 5
'******I used the two line above to test results, uncomment the line below and feel free to change M5 to any other renge location workd best for you
'        .Range("B" & lRow).Value = Worksheets(sSourceWSName).Range("M4").Value
'        .Range("C" & lRow).Value = Worksheets(sSourceWSName).Range("M5").Value
    End With
    RunTime = Now + TimeValue("00:00:01")
   Application.OnTime RunTime, "Chart_AppendData"
End Sub
Public Sub Chart_Stop()
'Stop capturing data
    On Error Resume Next
    Application.OnTime EarliestTime:=RunTime, Procedure:="Chart_AppendData", Schedule:=False
End Sub

EXCEL VBA宏编辑

1 个答案: