I have a list of serial numbers with run times that I am trying to graph via a combo graph in excel then push it to PowerPoint. I am using array operations to get the data for the graph, setting up 3 seriescollections and trying to get the serial numbers in a bar chart with counts, then line graphs correlating durations (aveage and total) of run times. The data is getting to the graph, and the values are correct in the select data window. Each series is also assigned the correct axisgroup (primary or secondary) in the graph's select data window. Any ideas why the plotted points for both lines are "0" (double clicking the data point on the graph also says the value is 0)?
I am dim-ing stuff() as variants. I know it's not right. I should either dim them as an arr() of type or arr as variant. IDK why it breaks for me when I do it another way, but it does. I'm also ears abouth that. lol. I appreciate any help!!!!
Here's the whole sub and functions (I leached the QuickSortArray from stack somewhere) as it is currently. I have formatting in ppt to do:
Code Updated with @FaneDuru's help:
Option Explicit
Sub Top_5_Graph()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim Exl As Excel.Application
Dim wbk As Workbook
Dim wks As Worksheet
Dim EXLfn As String
Dim i As Variant
Dim j As Variant
Dim rng As Range
Dim lastrow As Long
Dim dur As Variant
Dim serialNum() As Variant
Dim arr As Variant
Dim SerialNumCnt() As Variant
Dim top5() As Variant
Dim duration() As Variant
Dim aveDur() As Variant
Dim hidur As Variant
Dim counter As Integer
Dim cnt As Integer
Dim chrt As Variant
Dim chrtname As String
Dim xvalues() As Variant
Dim yvalues() As Variant
'Ask user for file
ChDir "\\myURL\"
Set wbk = Workbooks.Open(Application.GetOpenFilename("Microsoft Excel Files, *.xls*"))
'pulls file name to use for the ppt file name later
EXLfn = Split(Split(wbk.Name, "\")(UBound(Split(wbk.Name, "\"))), ".xlsx")(0)
Set wks = wbk.Worksheets("SN_Overview")
wks.Activate
lastrow = wks.Cells(Rows.count, "a").End(xlUp).Row
'removes blanks from AO
wks.AutoFilterMode = False
wks.Range("A1:BO" & lastrow).AutoFilter Field:=41, Criteria1:="<>", Operator:=xlFilterValues
Set rng = wks.Range("AO2:AO" & lastrow).SpecialCells(xlCellTypeVisible)
'loads SNs into array
serialNum = contArrayFromDscRng(rng)
'returns an array of just unique values
serialNum = GetUniqueDict(serialNum)
'adds counts to the array(sn, count)
For i = LBound(serialNum) To UBound(serialNum)
ReDim Preserve SerialNumCnt(LBound(serialNum) To UBound(serialNum), 0 To 1)
cnt = 0
For Each j In rng
If serialNum(i) = j.Value Then
cnt = cnt 1
End If
Next j
SerialNumCnt(i, 0) = serialNum(i)
SerialNumCnt(i, 1) = cnt
Next i
'orders array from largest
Call QuickSortArray(SerialNumCnt(), , , 2)
'add duration of each SN by adding column AL, "Duration"
For i = LBound(serialNum) To UBound(serialNum)
ReDim Preserve duration(LBound(serialNum) To UBound(serialNum))
For j = 1 To rng.Rows.count
If serialNum(i) = rng.Cells(j, 1) And duration(i) = "" Then
dur = Format(CDate(rng.Cells(j, -2)), "hh:mm:ss")
duration(i) = dur
ElseIf serialNum(i) = rng.Cells(j, 1) And duration(i) <> "" Then
dur = Format(CDate(rng.Cells(j, -2)), "hh:mm:ss")
duration(i) = Format(CDate(duration(i)) CDate(dur), "hh:mm:ss")
End If
Next j
Next i
'sets average durations
ReDim aveDur(LBound(duration) To UBound(duration))
For i = LBound(duration) To UBound(duration)
aveDur(i) = Format(CDate(duration(i)) / SerialNumCnt(i, 1), "hh:mm:ss")
Next i
'grabs the top 5 SNs and counts
If LBound(SerialNumCnt) 5 >= UBound(SerialNumCnt) Then
For i = LBound(SerialNumCnt) To UBound(SerialNumCnt)
ReDim Preserve top5(LBound(SerialNumCnt) To UBound(SerialNumCnt), 0 To 1)
top5(i, 0) = SerialNumCnt(i, 0)
top5(i, 1) = SerialNumCnt(i, 1)
Next i
Else
For i = LBound(SerialNumCnt) To LBound(SerialNumCnt) 5
ReDim Preserve top5(LBound(SerialNumCnt) To UBound(SerialNumCnt), 0 To 1)
top5(i, 0) = SerialNumCnt(i, 0)
top5(i, 1) = SerialNumCnt(i, 1)
Next i
End If
'gets highest duration to set secondary axis
For i = LBound(duration) To UBound(duration)
If Format(CDate(duration(i)), "hh:mm:ss") > Format(CDate(hidur), "hh:mss") Then
hidur = Format(duration(i), "hh:mm:ss")
End If
Next i
'trying to get percentage the highest duration is of 24 hours in decimal to set as secondary axis maximum
'hidur = Format(hidur, "hh:mm:ss") / Format("23:59:59", "hh:mm:ss")
'puts serial numbers as xvalues and counts as y values
ReDim xvalues(LBound(top5) To UBound(top5))
ReDim yvalues(LBound(top5) To UBound(top5))
For i = LBound(top5) To UBound(top5)
xvalues(i) = top5(i, 0)
yvalues(i) = top5(i, 1)
Next i
'graphs the arrays
wks.ShowAllData
'initialize chart
Set chrt = wks.ChartObjects.Add(Cells(7, "AP").Left, Cells(7, "AP").Top, 600, 300)
' chart properties
With chrt.Chart
.SeriesCollection.NewSeries
With .SeriesCollection(1)
.Values = yvalues
.xvalues = yvalues
.HasDataLabels = True
.Name = "Top 5 Serial Numbers"
.ChartType = xlColumnClustered
.AxisGroup = 1
.Interior.Color = RGB(255, 0, 0)
End With
.Axes(xlCategory, xlPrimary).CategoryNames = xvalues
.SeriesCollection.NewSeries
With .SeriesCollection(2)
.Values = aveDur
.xvalues = aveDur
.AxisGroup = 2
.Name = "Ave Duration"
.ChartType = xlLine
.Format.Line.ForeColor.RGB = RGB(0, 0, 0)
.Border.Weight = 4
.HasDataLabels = True
With .DataLabels
.NumberFormat = "[hh]:mm:ss;@"
.Position = xlLabelPositionCenter
End With
End With
.SeriesCollection.NewSeries
With .SeriesCollection(3)
.Values = duration
.xvalues = duration
.AxisGroup = 2
.Name = "Duration of SNs"
.ChartType = xlLine
.Format.Line.ForeColor.RGB = RGB(66, 128, 92)
.Border.Weight = 3
.HasDataLabels = True
With .DataLabels
.NumberFormat = "[hh]:mm:ss;@"
.Position = xlLabelPositionAbove
End With
End With
.ChartArea.Format.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Axes(xlValue, xlSecondary).TickLabels.NumberFormat = "[hh]:mm:ss;@"
.Axes(xlValue, xlSecondary).MaximumScale = 0.0005
.HasTitle = True
.ChartTitle.Text = "Top 5 Serial Numbers with Durations"
End With
'With chrt.PlotArea.Format.Fill.GradientStops
' .InsertRGB = RGB(255, 255, 255)
' .Position = 0
' .Brightness = 0.9
' .InsertRGB = RGB(241, 249, 249)
' .Position = 0.74
' .InsertRGB = RGB(241, 249, 249)
' .Position = 0.83
' .InsertRGB = RGB(249, 252, 253)
' .Position = 1
'End With
'sends chart to powerpoint
Call PubToPPT(chrt, EXLfn)
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Public Sub PubToPPT(chrt As Variant, FN As String)
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim i As Variant
Dim PPTpath As String
Dim PPTtfn As String
Dim PPTfn As String
Dim PPTapp As PowerPoint.Application
Dim PPTtemp As PowerPoint.Presentation
Dim PPTpres As PowerPoint.Presentation
Dim top5 As PowerPoint.Shape
'opens the template
PPTpath = "\\myURL\"
PPTtfn = "CURRENT_TEMPLATE_MASTER.pptx"
PPTfn = FN ".pptx"
Set PPTapp = CreateObject("PowerPoint.Application")
Set PPTtemp = PPTapp.Presentations.Open(PPTpath & PPTtfn, msoCTrue)
'saves template as new file name in the same folder
PPTtemp.SaveAs (PPTpath & PPTfn)
Set PPTpres = PPTtemp
'PPTapp.WindowState = ppWindowMinimized
'put chart image on slide
chrt.Copy
If chrt.Chart.ChartTitle.Text = "Top 5 Serial Numbers with Durations" Then GoTo top5
If chrt.Chart.ChartTitle.Text = "Confidence Levels with Durations" Then GoTo confidence
If chrt.Chart.ChartTitle.Text = "Activity by Platform" Then GoTo platform
If chrt.Chart.ChartTitle.Text = "Activity by Week" Then GoTo week
If chrt.Chart.ChartTitle.Text = "Activity by Weekday" Then GoTo weekday
If chrt.Chart.ChartTitle.Text = "Activity by Time of Day" Then GoTo tod
top5:
For i = 1 To PPTpres.Slides(1).Shapes.count
If PPTpres.Slides(1).Shapes(i).Name = "Chart*" Then
PPTpres.Slides(1).Shapes(i).Delete
End If
Next i
PPTpres.Slides(1).Shapes.Paste
confidence:
platform:
week:
weekday:
tod:
'pptpres.slides(
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Public Sub QuickSortArray(ByRef SortArray As Variant, Optional lngMin As Long = -1, Optional lngMax As Long = -1, _
Optional lngColumn As Long = 0)
On Error Resume Next
Dim i As Long
Dim j As Long
Dim varMid As Variant
Dim arrRowTemp As Variant
Dim lngColTemp As Long
If IsEmpty(SortArray) Then
Exit Sub
End If
If InStr(TypeName(SortArray), "()") < 1 Then 'IsArray() is somewhat broken: Look for brackets in the type name
Exit Sub
End If
If lngMin = -1 Then
lngMin = LBound(SortArray, 1)
End If
If lngMax = -1 Then
lngMax = UBound(SortArray, 1)
End If
If lngMin >= lngMax Then ' no sorting required
Exit Sub
End If
i = lngMin
j = lngMax
varMid = Empty
varMid = SortArray((lngMin lngMax) \ 2, lngColumn)
' We send 'Empty' and invalid data items to the end of the list:
If IsObject(varMid) Then ' note that we don't check isObject(SortArray(n)) - varMid *might* pick up a valid default member or property
i = lngMax
j = lngMin
ElseIf IsEmpty(varMid) Then
i = lngMax
j = lngMin
ElseIf IsNull(varMid) Then
i = lngMax
j = lngMin
ElseIf varMid = "" Then
i = lngMax
j = lngMin
ElseIf VarType(varMid) = vbError Then
i = lngMax
j = lngMin
ElseIf VarType(varMid) > 17 Then
i = lngMax
j = lngMin
End If
While i <= j
While SortArray(i, lngColumn) < varMid And i < lngMax
i = i 1
Wend
While varMid < SortArray(j, lngColumn) And j > lngMin
j = j - 1
Wend
If i <= j Then
' Swap the rows
ReDim arrRowTemp(LBound(SortArray, 2) To UBound(SortArray, 2))
For lngColTemp = LBound(SortArray, 2) To UBound(SortArray, 2)
arrRowTemp(lngColTemp) = SortArray(i, lngColTemp)
SortArray(i, lngColTemp) = SortArray(j, lngColTemp)
SortArray(j, lngColTemp) = arrRowTemp(lngColTemp)
Next lngColTemp
Erase arrRowTemp
i = i 1
j = j - 1
End If
Wend
If (lngMin < j) Then Call QuickSortArray(SortArray, lngMin, j, lngColumn)
If (i < lngMax) Then Call QuickSortArray(SortArray, i, lngMax, lngColumn)
End Sub
Private Function contArrayFromDscRng(rng As Range) As Variant 'makes 2D array from a discontinuous range i.e. filtered worksheet
Dim a As Range, arr, count As Long, i As Long
ReDim arr(1 To rng.Cells.count, 1 To 1): count = 1
For Each a In rng.Areas
For i = 1 To a.Cells.count
arr(count, 1) = a.Cells(i).Value: count = count 1
Next
Next
contArrayFromDscRng = arr
End Function
Function GetUniqueDict(arr As Variant) As Variant
Dim dict As Object, i As Long
Set dict = CreateObject("Scripting.Dictionary")
For i = LBound(arr) To UBound(arr)
dict(arr(i, 1)) = 1
Next i
GetUniqueDict = dict.Keys
End Function
CodePudding user response：
Please, use the next function to build a continuous array from a discontinuous range:
Private Function contArrayFromDscRng(rng As Range) As Variant 'makes 2D array from a discontinuous range
Dim a As Range, arr, count As Long, i As Long
ReDim arr(1 To rng.cells.count, 1 To 1): count = 1
For Each a In rng.Areas
For i = 1 To a.cells.count
arr(count, 1) = a.cells(i).value: count = count 1
Next
Next
contArrayFromDscRng = arr
End Function
You can use it in your code as:
serialNum = contArrayFromDscRng(rng)
The next function, will extract an array of unique values from another array:
Function GetUniqueDict(arr As Variant) As Variant
Dim dict As Object, i As Long
Set dict = CreateObject("Scripting.Dictionary")
For i = LBound(arr) To UBound(arr)
dict(arr(i, 1)) = 1
Next i
GetUniqueDict = dict.Keys
End Function
But it will return a 1D array. It can also be used like data sources for a chart.
But if you like your way of processing a 2D array, you can easily transform the returned 1D array. Inside the function, or outside. Something like this:
Dim arr
arr = GetUniqueDict(serialNum)
'transform it as a 2D array:
Dim i As Long
ReDim serialNum(1 To UBound(arr) 1, 1 To 1)
For i = 0 To UBound(arr)
serialNum(i 1, 1) = arr(i)
Next i