excel - VBA 根据相邻单元格值在散点图中显示每个标记

Question

想要根据已审核数据选项卡 W 列中的值为系列中的所有标记（已审核数据选项卡的 O 和 P 列中的 XY 值）着色

Sub ColorScatterPoints()
    Dim cht As Chart
    Dim srs As Series
    Dim pt As Point
    Dim p As Long
    Dim Vals$, lTrim#, rTrim#
    Dim valRange As Range, cl As Range
    Dim myColor As Long

    Set cht = ActiveSheet.ChartObjects("EastingNorthingGraph").Chart
    Set srs = cht.SeriesCollection("Survey Point")

    ' Get the series Y-Values range address (columns N and O in Reviewed Data tab
    lTrim = InStrRev(srs.Formula, ",", InStrRev(srs.Formula, ",") - 1, _
                     vbBinaryCompare) + 1
    rTrim = InStrRev(srs.Formula, ",")
    Vals = Mid(srs.Formula, lTrim, rTrim - lTrim)
    Set valRange = Range(Vals)

    For p = 1 To srs.Points.Count
        Set pt = srs.Points(p)
        'Colour lookup value is in Col W of Reviewed Data tab
        Set cl = valRange(p).Offset(0, 9)
        With pt.Format.Fill
            .Visible = msoTrue
            Select Case LCase(cl)
                Case "Crop"
                    myColor = RGB(255, 0, 0)
                Case "Gravel"
                    myColor = RGB(255, 192, 0)
                Case "Native Grass"
                    myColor = RGB(0, 255, 0)
            End Select
            .ForeColor.RGB = myColor
        End With
    Next
End Sub

标签： excelvba

Answer 1

根据您对我之前回答的评论中提供的新信息，您的方法应该改变，因为您的数据集太大了。VBA 方法的限制因素是与图表中的每个数据点交互所需的时间。您可以将数据范围移动到基于内存的数组中或禁用屏幕更新，但是使用该大小的数据集，您仍然需要修改Point. Series非常耗时。

这种不同的方法将您的数据集分为两列，并根据土地利用数据创建三个“虚拟”数据集。然后我们将向图表添加三个独立的数据系列，每个数据系列都可以单独设置颜色、大小、样式等样式。

逻辑首先为数据创建三个不同的范围：

Dim landUseWS As Worksheet
Set landUseWS = ThisWorkbook.Sheets("Sheet2")

Dim lastRow As Long
Dim xValues As Range
Dim yValues As Range
Dim useValues As Range
With landUseWS
    lastRow = .Cells(.Rows.Count, "N").End(xlUp).Row
    Set xValues = .Range("N1").Resize(lastRow, 1)
    Set yValues = .Range("O1").Resize(lastRow, 1)
    Set useValues = .Range("W1").Resize(lastRow, 1)
End With

接下来，我创建了一个Sub将我连接到土地利用图表本身。由于我反复测试代码，将这个逻辑移动到一个单独的子中让我有机会适当地设置图表。

Private Function GetLandUseChart(ByRef ws As Worksheet) As Chart
    Dim theChart As Chart
    On Error Resume Next
    Set theChart = ws.ChartObjects("EastingNorthingGraph").Chart
    If theChart Is Nothing Then
        '--- can't find it, so create it
        Dim newObject As ChartObject
        Set newObject = ws.ChartObjects.Add(Top:=10, Left:=325, _
                                            Width:=600, Height:=300)
        newObject.Name = "EastingNorthingGraph"
        Set theChart = newObject.Chart
        With theChart
            .ChartType = xlXYScatter
            .Location Where:=xlLocationAsObject, Name:=ws.Name
        End With
    End If

    '--- delete any existing series so we have an empty chart to work with
    Do Until theChart.SeriesCollection.Count = 0
        theChart.SeriesCollection(1).Delete
    Loop

    Set GetLandUseChart = theChart
End Function

下一步是Range从现有数据创建虚拟系列 ( )。您的数据基本上是三列：X、Y 和 LandUse。我们想要创建一个范围，将 X 和 Y 值与每个匹配的土地利用类型配对。范围内的单元格可能不连续，因此我们使用该Union函数创建一个范围对象，它将许多不同的单元格“分组”到一个范围内。我也把它分成了它自己的功能。

Private Function CreateLandUseSeries(ByVal useType As String, _
                                     ByRef xValues As Range, _
                                     ByRef yValues As Range, _
                                     ByRef useValues As Range) As Range
    Dim xData As Variant
    Dim yData As Variant
    Dim useData As Variant
    xData = xValues.Value
    yData = yValues.Value
    useData = useValues.Value

    Dim useRange As Range
    Dim i As Long
    For i = LBound(useData) To UBound(useData)
        If useData(i, 1) = useType Then
            If useRange Is Nothing Then
                Set useRange = Union(xValues(i, 1), yValues(i, 1))
            Else
                Set useRange = Union(useRange, xValues(i, 1), yValues(i, 1))
            End If
        End If
    Next i
    Set CreateLandUseSeries = useRange
End Function

那么你可以在你的主要逻辑中做到这一点：

Dim cropSeries As Range
Dim gravelSeries As Range
Dim nativeGrassSeries As Range
Set cropSeries = CreateLandUseSeries("Crop", xValues, yValues, useValues)
Set gravelSeries = CreateLandUseSeries("Gravel", xValues, yValues, useValues)
Set nativeGrassSeries = CreateLandUseSeries("Native Grass", xValues, yValues, useValues)

最后，将这些系列中的每一个都添加到图表中是一件简单的事情，也可以在其自己的Sub.

Private Sub AddSeries(ByVal newName As String, _
                      ByRef newSeries As Range, _
                      ByRef theChart As Chart, _
                      ByVal theMarker As XlMarkerStyle)
    Dim theSeries As Series
    With theChart
        Set theSeries = .SeriesCollection.newSeries
        With theSeries
            .Name = newName
            .xValues = newSeries.Resize(, 1)
            .Values = newSeries.Offset(, 1).Resize(, 1)
            '--- add some parameters to customize the marker style
            '    color, size, etc
            .MarkerStyle = theMarker
        End With
    End With
End Sub

请注意如何添加各种参数，以便更改标记样式、颜色或数据系列的任何其他方面。

AddSeries "Crop", cropSeries, landUseChart, xlMarkerStyleCircle
AddSeries "Gravel", gravelSeries, landUseChart, xlMarkerStyleDiamond
AddSeries "Native Grass", nativeGrassSeries, landUseChart, xlMarkerStyleSquare

或者，您可以添加逻辑来设置图表标题、自定义图例和图表的其他方面。

这是整个模块：

Option Explicit

Sub BuildLandUseChart()
    Dim landUseWS As Worksheet
    Set landUseWS = ThisWorkbook.Sheets("Sheet2")

    Dim lastRow As Long
    Dim xValues As Range
    Dim yValues As Range
    Dim useValues As Range
    With landUseWS
        lastRow = .Cells(.Rows.Count, "N").End(xlUp).Row
        Set xValues = .Range("N1").Resize(lastRow, 1)
        Set yValues = .Range("O1").Resize(lastRow, 1)
        Set useValues = .Range("W1").Resize(lastRow, 1)
    End With

    Dim landUseChart As Chart
    Set landUseChart = GetLandUseChart(landUseWS)

    Dim cropSeries As Range
    Dim gravelSeries As Range
    Dim nativeGrassSeries As Range
    Set cropSeries = CreateLandUseSeries("Crop", xValues, yValues, useValues)
    Set gravelSeries = CreateLandUseSeries("Gravel", xValues, yValues, useValues)
    Set nativeGrassSeries = CreateLandUseSeries("Native Grass", xValues, yValues, useValues)

    AddSeries "Crop", cropSeries, landUseChart, xlMarkerStyleCircle
    AddSeries "Gravel", gravelSeries, landUseChart, xlMarkerStyleDiamond
    AddSeries "Native Grass", nativeGrassSeries, landUseChart, xlMarkerStyleSquare

End Sub

Private Sub AddSeries(ByVal newName As String, _
                      ByRef newSeries As Range, _
                      ByRef theChart As Chart, _
                      ByVal theMarker As XlMarkerStyle)
    Dim theSeries As Series
    With theChart
        Set theSeries = .SeriesCollection.newSeries
        With theSeries
            .Name = newName
            .xValues = newSeries.Resize(, 1)
            .Values = newSeries.Offset(, 1).Resize(, 1)
            '--- add some parameters to customize the marker style
            '    color, size, etc
            .MarkerStyle = theMarker
        End With
    End With
End Sub

Private Function GetLandUseChart(ByRef ws As Worksheet) As Chart
    Dim theChart As Chart
    On Error Resume Next
    Set theChart = ws.ChartObjects("EastingNorthingGraph").Chart
    If theChart Is Nothing Then
        '--- can't find it, so create it
        Dim newObject As ChartObject
        Set newObject = ws.ChartObjects.Add(Top:=10, Left:=325, _
                                            Width:=600, Height:=300)
        newObject.Name = "EastingNorthingGraph"
        Set theChart = newObject.Chart
        With theChart
            .ChartType = xlXYScatter
            .Location Where:=xlLocationAsObject, Name:=ws.Name
        End With
    End If

    '--- delete any existing series so we have an empty chart to work with
    Do Until theChart.SeriesCollection.Count = 0
        theChart.SeriesCollection(1).Delete
    Loop

    Set GetLandUseChart = theChart
End Function

Private Function CreateLandUseSeries(ByVal useType As String, _
                                     ByRef xValues As Range, _
                                     ByRef yValues As Range, _
                                     ByRef useValues As Range) As Range
    Dim xData As Variant
    Dim yData As Variant
    Dim useData As Variant
    xData = xValues.Value
    yData = yValues.Value
    useData = useValues.Value

    Dim useRange As Range
    Dim i As Long
    For i = LBound(useData) To UBound(useData)
        If useData(i, 1) = useType Then
            If useRange Is Nothing Then
                Set useRange = Union(xValues(i, 1), yValues(i, 1))
            Else
                Set useRange = Union(useRange, xValues(i, 1), yValues(i, 1))
            End If
        End If
    Next i
    Set CreateLandUseSeries = useRange
End Function