如何遍历表中的数据并将其添加到图表

Question

我试图使用 Excel VBA 解决的问题是我想要循环并添加到图表的信息表。

例如数据文件的格式如下：

 -696.710022 48 0 
 0 415.853546 2 1
 5 417.769196 2 1
 10 419.684845 2 1
 15 421.600464 2 1
 20 423.516113 2 1
 ......
 -602 48 0 
 0 371.893372 2 1
 5 373.851685 2 1
 10 375.810028 2 1
 15 377.768372 2 1
 20 379.726685 2 1
 ......
 -497.76001 48 0 
 0 323.194183 2 1
 5 325.189819 2 1
 10 327.185486 2 1
 15 329.181152 2 1
 20 331.176819 2 1
 ......
 etc.

在此文件中，如果第 3 列 = “0”，则这是标题行，其中：

column 1 = location, 
column 2 = number of points at location, 
column 3 = header flag (i.e. "0")

其余的行是数据：

column 1 = X value,
column 2 = Y value,
column 3 = colour of points (i.e. 1 = green, 2 = blue, 3 = red).

我想在 VBA 中运行它，因为我要制作 40 个左右的图表。除了导入图表之外，我一直在努力为 VBA 编写脚本，所以我没有在此处包含我的代码。

我非常感谢任何有关如何解决此问题的建议或建议。

谢谢你:)

Answer 1

假设标题行的第二列中的值显示到下一个标题行的行数（示例数据有一段时间后...），这将设置数据，插入图表和颜色点。

Sub DoCharts()
  Dim iRow As Long, nRows As Long, iPt As Long, nPts As Long
  Dim rXVals As Range, rYVals As Range, rColor As Range
  Dim cht As Chart

  With ActiveSheet.UsedRange
    For iRow = 1 To .Rows.Count
      If .Cells(iRow, 3).Value = 0 And Len(.Cells(iRow, 3).Text) > 0 Then
        ' value is zero and cell is not blank

        'define X and Y values
        nPts = .Cells(iRow, 2).Value
        Set rXVals = .Cells(iRow + 1, 1).Resize(nPts)
        Set rYVals = rXVals.Offset(, 1)
        Set rColor = rXVals.Offset(, 2)

        ' chart
        Set cht = ActiveSheet.Shapes.AddChart(xlXYScatter, , .Cells(iRow, 1).Top).Chart

        ' clear existing series
        Do While cht.SeriesCollection.Count > 0
          cht.SeriesCollection(1).Delete
        Loop

        ' add desired series
        With cht.SeriesCollection.NewSeries
          .Values = rYVals
          .XValues = rXVals
        End With

        ' point color
        For iPt = 1 To nPts
          With cht.SeriesCollection(1).Points(iPt)
            Select Case rColor.Cells(iPt)
              Case 1 ' green
                .MarkerForegroundColor = vbGreen ' use nicer colors, of course
                .MarkerBackgroundColor = vbGreen
              Case 2 ' blue
                .MarkerForegroundColor = vbBlue
                .MarkerBackgroundColor = vbBlue
              Case 3 ' red
                .MarkerForegroundColor = vbRed
                .MarkerBackgroundColor = vbRed
            End Select
          End With
        Next
      End If

      cht.HasLegend = False

      iRow = iRow + nPts
    Next
  End With
End Sub

编辑 - 在同一个图表中绘制所有内容。

我做了一些小改动。我仍然使用每个数据块中的单个 X 值。但我假设整个系列都具有相同的颜色格式，所以我按系列而不是按点进行格式化。我将每个系列格式化为带有标记的线条，而不仅仅是标记。我还使用每个标题行中的第一个单元格作为系列名称，所以这些是图例中系列的区别。最后我没有重新定位图表，而是让 Excel 将其放置在默认位置。

Sub DoOneChart()
  Dim iRow As Long, nRows As Long, iPt As Long, nPts As Long
  Dim rXVals As Range, rYVals As Range, rName As Range
  Dim iColor As Long
  Dim cht As Chart

  With ActiveSheet.UsedRange
    For iRow = 1 To .Rows.Count
      If .Cells(iRow, 3).Value = 0 And Len(.Cells(iRow, 3).Text) > 0 Then
        ' value is zero and cell is not blank

        'define X and Y values
        nPts = .Cells(iRow, 2).Value
        Set rXVals = .Cells(iRow + 1, 1).Resize(nPts)
        Set rYVals = rXVals.Offset(, 1)
        iColor = .Cells(iRow + 1, 3).Value
        Set rName = .Cells(iRow, 1)

        ' chart
        If cht Is Nothing Then
          Set cht = ActiveSheet.Shapes.AddChart(xlXYScatterLines).Chart
          ' clear existing series
          Do While cht.SeriesCollection.Count > 0
            cht.SeriesCollection(1).Delete
          Loop
        End If

        ' add desired series
        With cht.SeriesCollection.NewSeries
          .Values = rYVals
          .XValues = rXVals
          .Name = "=" & rName.Address(, , , True)

          ' series color
          Select Case iColor
            Case 1 ' green
              .MarkerForegroundColor = vbGreen ' use nicer colors, of course
              .MarkerBackgroundColor = vbGreen
              .Border.Color = vbGreen
            Case 2 ' blue
              .MarkerForegroundColor = vbBlue
              .MarkerBackgroundColor = vbBlue
              .Border.Color = vbBlue
            Case 3 ' red
              .MarkerForegroundColor = vbRed
              .MarkerBackgroundColor = vbRed
              .Border.Color = vbRed
          End Select
        End With

      End If

      iRow = iRow + nPts
    Next
    cht.HasLegend = True
  End With
End Sub