Как перебрать данные в таблицу и добавить ее в диаграмму

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 

EDIT - Участок все в одном графике.

Я внес незначительные изменения. Я все еще использовал отдельные значения 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