Add values to a graph depending of a value - excel

Question

I'm currently working on a project which needs to build graph regarding to a table of analyses to check if the products work with time.
The user starts to choose which products he want to check and the code create a table regarding that.
The two main values are the date and the result which need to be on the graph and the third one is the batch number which needs to be the name of each chart series.
After that the code creates a 2D array with the table.
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
And after that I want to create the graph regarding to the number of different batch number that I have.
'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
So I need something to add the series regarding of the number of different batch number and insert the value and the date there.
I'm a beginner with charts in VBA.

Answer 1

if my understanding of the objective is correct then congratulation for a good & challenging question. Assuming the objective is to create a single chart with multiple series representing each batch listed in the range. If assumed result is like the following
then may try the test code (obviously after modifying the range, sheet etc to requirement). The code used Dictionary object, so please add Tools-> Reference to "Microsoft Scripting Runtime". Though I am not fully satisfied with the code regarding some multiple looping etc (degrading the performance) but would work OK with normal data assuming 100/200 rows. I invite experts response for more efficient code in this regard
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
Please comment if it suits your need

Answer 2

This code should create a table regarding to another table (the one with all different batch numbers and values) and the user selection and after build the chart with it.
I can send you the full file by mail if needed.
Thanks in advance.
Best regards
colin
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