根据值将值添加到图中

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

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

​

​

然后可以尝试测试代码(显然在修改range、sheet等以满足要求之后)。代码使用了Dictionary对象，因此请在"Microsoft脚本运行时“中添加”工具“->”引用“。虽然我对一些关于多循环等(降低性能)的代码并不完全满意，但对于假设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

如果适合您的需要，请留言

Answer 2

这段代码应该创建一个关于另一个表(具有所有不同批号和值的表)和用户选择的表，然后用它构建图表。

如果需要的话，我可以邮寄完整的文件给你。

提前谢谢。

诚挚的问候

科林

Private Sub BtnGraph2_Click()
    Dim tabBNumber() As String
    Dim tabHumidite() As Double
    Dim tabDate() As String
    Dim tabReo() As String
    Dim y As Integer
    Dim h As Integer
    Dim d As Integer
    Dim a As Integer
    Dim w As Integer
    Dim w2 As Integer
    Dim r As Integer
    h = 0
    y = 0
    d = 0
    w = 1
    w2 = 1
    r = 0
    ReDim tabHumidite(h)
    ReDim tabBNumber(y)
    ReDim tabDate(d)
    Range("tabReorganize[#data]") = ""
    ListObjects("tabReorganize").Resize Range(Range("tabReorganize[#headers]").Address, Range("tabReorganize[#headers]").Offset(1).Address)


    For i6 = ListBox1.ListCount - 1 To 0 Step -1
        If ListBox1.Selected(i6) = True Then
            ReDim Preserve tabBNumber(y)
            tabBNumber(y) = ListBox1.List(i6)
            y = y + 1
        End If
    Next i6

    For Each delement In tabBNumber
        For Each delement2 In Range("tabGraph[Date]")
            If "0" & delement2.Offset(0, 2) = delement Or delement2.Offset(0, 2) = delement Then
                ReDim Preserve tabDate(d)
                tabDate(d) = delement2
                d = d + 1
            End If
        Next delement2
    Next delement

    For Each Oelement In tabDate
        Range("tabReorganize[Date]").Cells(w) = Format(Oelement, "mm/dd/yyyy")
        w = w + 1
    Next Oelement



    If BtnHumidite = True Then
        For Each element In tabBNumber
            h = 0
            a = 0
            ReDim tabHumidite(h)

            For Each Gelement In Range("tabGraph[Humidite]")
                If "0" & Gelement.Offset(0, -1) = element Or Gelement.Offset(0, -1) = element Then
                    ReDim Preserve tabHumidite(h)
                    tabHumidite(h) = Gelement
                    h = h + 1
                End If
            Next Gelement


            For Each O2element In tabHumidite
                Range("tabReorganize[Humidite]").Cells(w2) = Format(O2element, "###0.00")
                Range("tabReorganize[Batch Number]").Cells(w2) = Format(element, "00000000")
                w2 = w2 + 1
            Next O2element
        Next element
    End If

    Range("tabReorganize").Sort Key1:=Range("tabReorganize[[#All],[Date]]"), Order1:=xlAscending, Header:=xlYes

    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

    '''' Chart part

    Dim Cht As Chart, ChartObj As ChartObject
    Set ChartObj = ActiveSheet.ChartObjects.Add(Left:=2979.75, Width:=550, Top:=358.5, Height:=325)
    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("AP13:AP42")  'Modify to requireMent
    'Set Rng = ThisWorkbook.ActiveSheet.Range("tabReorganize[Date]")
    DataArr = ThisWorkbook.ActiveSheet.Range("AP13:AR42")  'Modify to requireMent
    'DataArr = ThisWorkbook.ActiveSheet.Range("tabReorganize[#data]")
    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 = "mm/dd/yy"

End With