VBA根据相邻像元值在散点图中充实每个标记

时间：2019-07-25 09:41:07

标签： excel vba

要根据“检查数据”标签的W列中的值为系列中的所有标记着色（“检查数据”标签的O和P列中的XY值）

beforeunload

2 个答案:

答案 0 :(得分：0)

您的代码实际上只有一个问题。用于获取土地使用数据的Offset减1。使用

 Set cl = valRange(p).Offset(0, 8)

它应该可以工作。

由于我自己编写了代码以进行检查，因此这是我的版本（略有不同）。请注意以下几点：

  1. 将变量声明为尽可能靠近首次使用的位置。如果需要的话，这使得以后查找（和更改）变得更加容易。
  2. 变量名称更具描述性，并使代码“读取”更加容易。在某种程度上，它是自我记录。
  3. 使用Split函数获得Range字符串以获取x值范围。对我来说，拆分Formula字符串比解析它几次要容易得多。
  4. 单独声明变量。我知道，它似乎占据了更多的垂直空间，但它使将来的更改变得更容易（个人喜好）。另外，使用String声明$和使用Long声明#并不是完全不推荐使用，但是最近很少使用。
  5. 自从您使用LCase对土地使用字符串进行了规范化以来，每个Case语句都应该全部小写。
  6. 我正在使用Offset(0, 9)，因为我正在使用x值范围。您使用了y值范围。

这是我的版本（略有不同）：

Sub ColorScatterPoints2()
    Dim thisWS As Worksheet
    Dim thisChart As Chart
    Dim thisSeries As Series
    Set thisWS = ActiveSheet
    Set thisChart = thisWS.ChartObjects("EastingNorthingGraph").Chart
    Set thisSeries = thisChart.SeriesCollection("Survey Point")

    '--- establish a Range for the "x" values of the series
    '    and use it to create a Range for the Land Use data
    Dim landUseArea As Range
    Dim xValues As Range
    Dim tokens() As String
    tokens = Split(thisSeries.Formula, ",")
    Set xValues = Range(tokens(1))
    Set landUseArea = xValues.Offset(0, 9)

    Dim i As Long
    Dim thisPoint As Point
    Dim myColor As Long
    For i = 1 To thisSeries.Points.Count
        Select Case LCase(landUseArea.Cells(i, 1))
            Case "crop"
                myColor = RGB(255, 0, 0)
            Case "gravel"
                myColor = RGB(255, 192, 0)
            Case "native grass"
                myColor = RGB(0, 255, 0)
        End Select
        Set thisPoint = thisSeries.Points(i)
        With thisPoint.Format.Fill
            .Visible = msoTrue
            .ForeColor.RGB = myColor
        End With
    Next i
End Sub

答案 1 :(得分：0)

在您对我之前的回答的评论中提供了新信息后，应该更改您的方法，因为您的数据集非常大。 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
相关问题
最新问题