VBA - 根据A列中的值是否已更改添加系列

Question

我有一些看起来像这样的数据...

Area Name   x value y value sum mia3ever    proportion  Postcode
London  0.71926819  0.194887721 257 12% TW13
London  0.249070388 0.678239918 153 7%  TW13
London  0.895600342 0.50096083  102 5%  TW13
London  0.226127681 0.286161753 32  2%  TW13
London  0.063482651 0.997888216 56  3%  TW13
London  0.559486828 0.3184387   44  2%  TW13
London  0.505436766 0.627708014 32  2%  TW13
London  0.51053101  0.90729441  21  1%  TW13
London  0.793446485 0.429025666 13  1%  TW13
London  0.984280399 0.961682652 7   0%  TW13
Swindon 0.40981356  0.89159907  321 15% SN3
Swindon 0.476922958 0.877030395 221 11% SN3
Swindon 0.054196462 0.630455049 128 6%  SN3
Swindon 0.50651053  0.250699362 194 9%  SN3
Swindon 0.765687797 0.291577129 126 6%  SN3
Swindon 0.349227537 0.642574308 23  1%  SN3
Birmingham  0.061425423 0.307267677 176 8%  B1
Birmingham  0.055064149 0.00827374  111 5%  B1
Birmingham  0.044373053 0.978586414 66  3%  B1 

到目前为止，我的代码看起来像这样......

Option Explicit

Sub MakeChart()
Dim LastRow As Long
Dim LastColumn As Long
Dim aRng As Range
Dim seriescheck As Range

Set aRng = Selection.CurrentRegion
    LastRow = aRng.End(xlDown).Row
    LastColumn = aRng.End(xlToRight).Column
        msg = MsgBox("Last Row: " & LastRow & ", Last Column: " & LastColumn)
Set aRng = aRng.offset(1, 0).Resize(aRng.Rows.Count - 1)
Set seriescheck = aRng.offset(1, 0).Resize(aRng.Rows.Count - 1, 1)

seriescheck.Select

For Each cell In seriescheck
If cell.value <> cell.offset(1, 0).value Then
    MsgBox ("Row: " & cell.Row)
End If

Next

End Sub

由于我是新用户，我不确定您是否可以看到该图像，但我还是会描述一下。它是邮政编码数据，A 列有地区名称（例如伦敦、斯温顿、伯明翰）。我需要此代码将每个区域作为新系列添加到散点图中。

到目前为止，我已经弄清楚如何识别每个系列的结尾，但我现在需要将这些添加到图表对象中，并让代码在到达最后一行时结束。我是 VBA 新手，正在尝试掌握它，有人可以帮忙吗？

提前致谢。

Answer 1

我稍微编辑了您的代码，并添加了将您的数据添加到图表的代码。

我不确定您要绘制数据的哪一部分，所以我假设您想要绘制 X-val / Y-val 列的散点图，其中 AreaName 作为系列名称.

您需要在工作表中添加一个空白散点图，并更新下面的“Set cht = ....”行以引用它。

希望对您有所帮助，祝您顺利完成。

Option Explicit

Sub MakeChart()
Dim LastRow As Long
Dim LastColumn As Long
Dim aRng As Range
Dim seriescheck As Range

    Set aRng = Selection.CurrentRegion
    Set aRng = aRng.Offset(1, 0).Resize(aRng.Rows.Count - 1)
    Set seriescheck = aRng.Resize(aRng.Rows.Count, 1)

    Dim cht As Chart, seriesName As String, seriesData As Range

    'Set reference to chart: need to update this to match the location and name of the chart you create
    Set cht = Sheet1.ChartObjects("Chart 1").Chart

    'Clear any series currently on the chart
    Call ClearChartSeries(cht)

    Dim cell As Range
    Dim startRow As Long, endRow As Long, cnt As Long

    'Loop through, find series data and add to chart
    startRow = 1: cnt = 0
    For Each cell In seriescheck
        cnt = cnt + 1
        If cell.Value <> cell.Offset(1, 0).Value Then
            endRow = startRow + cnt - 1
            Set seriesData = aRng.Offset(startRow - 1, 1).Resize(endRow - startRow + 1, 2)
            seriesName = cell.Value
            Call AddChartSeries(cht, seriesName, seriesData)
            startRow = endRow + 1: cnt = 0
        End If
    Next

End Sub


'Expecting two columns: date and index values
'Assumes x and y values are next to each other
Public Function AddChartSeries(cht As Chart, seriesName As String, rngData As Range)

    'Set data references
    Dim xAddress As String, yAddress As String
    xAddress = rngData.Parent.Name & "!" & rngData.Resize(rngData.Rows.Count, 1).Address
    yAddress = rngData.Parent.Name & "!" & rngData.Resize(rngData.Rows.Count, 1).Offset(0, 1).Address

    'Add a new series to the chart with these data references
    Dim seriesCnt As Long
    seriesCnt = cht.SeriesCollection.Count

    cht.SeriesCollection.NewSeries
    cht.SeriesCollection(seriesCnt + 1).Name = seriesName
    cht.SeriesCollection(seriesCnt + 1).XValues = xAddress
    cht.SeriesCollection(seriesCnt + 1).Values = yAddress

End Function

'Removes all series from a chart
'Used to clear charts before adding new data
Public Sub ClearChartSeries(cht As Chart)

    Dim s As Series

    'Flush all existing series
    For Each s In cht.SeriesCollection
        s.Delete
    Next s

End Sub