excel - 根据值向图表添加值

Question

我目前正在开展一个项目，该项目需要构建关于分析表的图表，以检查产品是否随时间工作。
用户开始选择他想要检查的产品，然后代码创建一个与之相关的表格。
两个主要值是需要在图表上显示的日期和结果，第三个是需要作为每个图表系列名称的批号。

之后，代码会使用表格创建一个二维数组。

For Each elementReo In Range("tabReorganize[Date]")
   ReDim Preserve tabReo(2, r)
   tabReo(0, r) = elementReo
   tabReo(1, r) = 0 & elementReo.Offset(0, 1)
   tabReo(2, r) = elementReo.Offset(0, 2)
   r = r + 1
Next elementReo

之后，我想创建关于我拥有的不同批号数量的图表。

'This part create the Chart and set the title
    Set ChartObj = ActiveSheet.ChartObjects.Add(Left:=2979.75, Width:=550, Top:=358.5, Height:=325)
    ChartObj.Chart.ChartType = xlLine
    ChartObj.Chart.SetElement (msoElementChartTitleAboveChart)
    ChartObj.Chart.ChartTitle.Text = "Humidite"
    
    Dim tabNBN() As String
    Dim NBN As Integer
    Dim checkNBN As Boolean
    ReDim tabNBN(NBN)
    Dim SeriesI As Integer
    
    NBN = 0
    SeriesI = 0
    
    'Add value in tabNBN regarding to the number of different batch number
    For r2 = 0 To r - 1 Step 1
        checkNBN = False
        For Each elementNBN In tabNBN
            If elementNBN = tabReo(1, r2) Then
                checkNBN = True
            End If
        Next elementNBN
                    
        If checkNBN = False Then
            ReDim Preserve tabNBN(NBN)
            tabNBN(NBN) = tabReo(1, r2)
            NBN = NBN + 1
        End If
    Next r2

所以我需要一些东西来添加关于不同批号数量的系列，并在那里插入值和日期。
我是 VBA 中图表的初学者。

Answer 1

如果我对目标的理解是正确的，那么恭喜你提出了一个好的和具有挑战性的问题。假设目标是创建一个包含多个系列的单个图表，这些系列代表该范围中列出的每个批处理。如果假设结果如下



然后可以尝试测试代码(显然在将范围、表格等修改为要求之后)。代码使用了 Dictionary 对象，所以请在“Microsoft Scripting Runtime”中添加Tools-> Reference。尽管我对有关某些多重循环等(降低性能)的代码并不完全满意，但假设 100/200 行的正常数据可以正常工作。我邀请专家回应在这方面更有效的代码

Option Explicit
Sub test3()
    Dim Cht As Chart, ChartObj As ChartObject
    Set ChartObj = ActiveSheet.ChartObjects.Add(Left:=10, Width:=550, Top:=10, Height:=325)
    'Set ChartObj = ActiveSheet.ChartObjects("Chart 4")
    Set Cht = ChartObj.Chart
    Cht.ChartType = xlLine
    Cht.HasTitle = True
    Cht.ChartTitle.Text = "Humidite"


    Dim Rw As Long, Dic As Dictionary, DataArr As Variant, OutArr() As Variant, BatchArr() As Variant, DateArr As Variant
    Dim Rng As Range, SeriesNo As Long, Dmax As Date, Dmin As Date, dt As Date
    Dim X As Long, i As Long, Xbatch As Variant, Batch As Variant
    Dim Cnt As Long, Xval As Variant, PrvDt As Date, C As Range, DayCnt As Long
    Dim firstAddress As String

    Set Dic = CreateObject("Scripting.dictionary")
    Set Rng = ThisWorkbook.ActiveSheet.Range("A2:A100")  'Modify to requireMent
    DataArr = ThisWorkbook.ActiveSheet.Range("A2:C100")  'Modify to requireMent
    SeriesNo = 0

        'Create dictionary reference to unique Batch name from the list
        For Rw = 1 To UBound(DataArr, 1)
        Batch = DataArr(Rw, 2)
            If Dic.Exists(Batch) = False Then
            SeriesNo = SeriesNo + 1
            Dic.Add Batch, SeriesNo
            End If
        Next

Dmax = Application.WorksheetFunction.Max(Range(Rng(1, 1), Rng(Rng.Rows.Count, 1)))
Dmin = Application.WorksheetFunction.Min(Range(Rng(1, 1), Rng(Rng.Rows.Count, 1)))
DayCnt = Dmax - Dmin + 1

ReDim BatchArr(1 To DayCnt)
ReDim DateArr(1 To DayCnt)
ReDim OutArr(1 To SeriesNo, 1 To DayCnt)

    'Populate DateArr for dates
    For X = 1 To DayCnt
    DateArr(X) = Dmin + X - 1
    Next

    'Populate OutArr(Series,DayCnt) with existing Values, Non existing values are kept empty
    For X = 1 To DayCnt
    dt = DateArr(X)
    With Rng
    Set C = .Find(dt)
        If Not C Is Nothing Then
        firstAddress = C.Address
            Do
            OutArr(Dic(C.Offset(0, 1).Value), X) = C.Offset(0, 2).Value
            'Debug.Print C.Value, C.Offset(0, 1).Value, C.Offset(0, 2).Value
            Set C = .FindNext(C)
            Loop While Not C Is Nothing And C.Address <> firstAddress
        End If
    End With
    Next

With Cht
    'delete If any automatically added series
    For i = Cht.SeriesCollection.Count To 1 Step -1
    .SeriesCollection(i).Delete
    Next


    'Create Series and Set Values & Xvalues from OutArr
    Dim Srs As Series
    For X = 1 To SeriesNo
    Batch = Dic.Keys(X - 1)
        For Cnt = 1 To DayCnt
        BatchArr(Cnt) = OutArr(Dic(Batch), Cnt)
        'If IsEmpty(BatchArr(Cnt)) = False Then Debug.Print X, Cnt, BatchArr(Cnt), DateArr(Cnt)
        Next
    Cht.SeriesCollection.NewSeries
    Set Srs = Cht.SeriesCollection(X)
        With Srs
        .Values = BatchArr
        .XValues = DateArr
        .Name = Dic.Keys(X - 1)
        End With
    Next

    Dim Cat As Axis
    Set Cat = Cht.Axes(xlCategory)
    Cat.TickLabels.NumberFormat = "dd/mm/yy"

End With
End Sub

请评论是否适合您的需要