this question was already discussed in different topics but the solutions are not helping me. I am trying to calculate and display a series of data for a chart. Something like "Calculate y" --> "Update Series" --> wait 100 ms --> "Recalculate". The program is running but the chart is only updated when the Main-Sub is completely finished (and not after each 100 ms).
The series is based entirely on arrays within VBA and do not refer to Cells.
When I'm running the program with break points directly after the "sleep" function, the chart is updated.
For me the DoEvents and chart.Refresh method are not giving me the results I want. Does somebody has an idea? Thanks for your help guys.
Sub Main()
Dim ws As Worksheet
Dim mychart As Chart
Dim ser As Series
Dim x(1 To 10) As Double
Dim y(1 To 10) As Double
Dim i As Integer
Set ws = ThisWorkbook.Sheets("Sheet1")
Set mychart = ws.ChartObjects("Chart 1").Chart
Call DeletePlot(mychart)
For i = 1 To 10
x(i) = i
y(i) = i
Next i
' Plot first data
Set ser = mychart.SeriesCollection.NewSeries
With ser
.Values = y
.XValues = x
End With
Dim j As Integer
For j = 2 To 4
For i = 1 To 10
y(i) = i ^ j ' update data
Next i
With ser
.Values = y ' update series
End With
mychart.Refresh ' Does not work
DoEvents ' Does not work
Sleep (100)
Next j
End Sub
The sleep function:
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
The PlotDelete Function:
Sub DeletePlot(mychart As Chart)
Dim ser As Series
For Each ser In mychart.SeriesCollection
ser.Delete
Next ser
End Sub
A timer such as Application.OnTime or a windows API timer see link gave me the desired behaviour.
Related
I am trying to make a fairly easy macro to activate the next series in an already active chart. (my main macro contains all the formatting stuff).
Problem with this coding, is that i am not able to assign the current active series (already selected in the graph in excel). In a graph with n series (SeriesCollection.Count = n) I want to go from x, to x+1 and if x=n i want to go back to series 1 (so the for/next included here is not necessary if I get the macro to work as intended).
Sub NextButton_Click()
Dim cht As Chart
Set cht = ActiveChart
If cht Is Nothing Then
MsgBox "Select a chart."
Exit Sub
End If
With cht
For SrsIndx = 1 To .SeriesCollection.Count
.SeriesCollection(SrsIndx).Select
Next SrsIndx
End With
End Sub
For Simple graphs, just use PlotOrder: If you are not using a Combo Chart (i.e. not mixing Line and Bar charts, and not using the Secondary Axis), then you can just use the following code:
IIF(TypeName(Selection)="Series", Selection.PlotOrder, -1)
This will return -1 if you do not have a Series selected.
However, this is actually the order within the ChartGroup - the conditions above were for when there is only 1 ChartGroup on the Chart.
Otherwise, try using Name and a loop:
Function ActiveSeriesNumber(ThisSeries AS Series) AS Long
Dim ThisChart AS Chart, TestNumber AS Long
ActiveSeriesNumber = -1
On Error GoTo FunctionError
Set ThisChart = ThisSeries.Parent.Parent 'Object Model Is Chart.ChartGroup.Series
For TestNumber = 1 to ThisChart.SeriesCollection.Count
If ThisChart.SeriesCollection(TestNumber).Name = ThisSeries.Name THen
ActiveSeriesNumber = TestNumber
Exit Function
End If
Next TestNumber
FunctionError:
On Error GoTo -1
End Function
Use this by calling ActiveSeriesNumber(Selection)
Here's the General Idea. Step through that code and you can see each series gets selected. You'll need add some object validation as this assumes the selected object is a Series.
Sub CycleSeries()
Dim MyObject As ChartObject
Dim MyChart As Chart
Dim SerCol As SeriesCollection
Dim SelSeries As Series
Dim indexSeries As Series
Dim ChartSheet As Worksheet
Dim x As Integer
Set ChartSheet = ThisWorkbook.Sheets(1)
Set MyObject = ChartSheet.ChartObjects(1)
Set MyChart = MyObject.Chart
Set SerCol = MyChart.SeriesCollection
Set SelSeries = Excel.Application.Selection
For x = 1 To SerCol.Count
Set indexSeries = SerCol(x)
If indexSeries.Name = SelSeries.Name Then
If (x = SerCol.Count) Then
Set SelSeries = SerCol(1)
SelSeries.Select
Exit For
Else
Set SelSeries = SerCol(x + 1)
SelSeries.Select
Exit For
End If
End If
Next x
End Sub
I'm currently trying to add a data label to only the last point of each series in each graph on a worksheet. I'm currently adapting one of the solutions proposed here: "https://superuser.com/questions/1285179/adding-data-label-only-to-the-last-value".
However, my code keeps on popping up with the error: "Runtime error '13', type mismatch". When I go in debug mode, it higlights the line "Set chrt = ws.ChartObjects(Chart_Name)".
Sub LastDataLabel()
Dim Chart_Name As String
Dim i, Total_Charts, Total_Series As Integer
Dim ws As Worksheet
Dim chrt As Chart
Dim srs As Series
Dim pnt As Point
Dim p As Integer
Application.ScreenUpdating = False
Set ws = ActiveSheet
Total_Charts = Range("C12").Value
For i = 1 To Total_Charts
Chart_Name = ActiveSheet.Cells(14 + i, 2).Value 'A list of all chart names exists along this range
Set chrt = ws.ChartObjects(Chart_Name)
Total_Series = chrt.SeriesCollection.Count
For j = 1 To Total_Series
Set srs = chrt.SeriesCollection(j)
srs.ApplyDataLabels
For p = 1 To srs.Points.Count - 1
Set pnt = srs.Points(p)
pnt.DataLabel.Text = ""
Next
srs.Points(srs.Points.Count).DataLabel.Format.TextFrame2.TextRange.Font.Size = 10
srs.Points(srs.Points.Count).DataLabel.Format.TextFrame2.TextRange.Font.Name = "Arial"
Next j
Next i
End Sub
Any and all help is greatly appreciated. Thank you!
ChartObject is just a container shape for the chart - it's not the actual chart itself
This should improve things:
Set chrt = ws.ChartObjects(Chart_Name).Chart
My code is working fine but it ends up giving me a runtime error "object required.
I am not able to find out what is causing this error. This code is related to deleting graphs that don't have any data in them .
Sub HideEmptyCharts()
Dim wksCharts As Worksheet
Dim objCO As ChartObject
' Set up a variable for the worksheet containing the charts
Set wksCharts = ThisWorkbook.Sheets("Report output")
' Loop through every embedded chart object on the worksheet
For Each objCO In wksCharts.ChartObjects
' Make each one visible
objCO.Visible = True
' If the chart is empty make it not visible
If IsChartEmpty(objCO.Chart) Then objCO.Visible = False
Next objCO
End Sub
Private Function IsChartEmpty(chtAnalyse As Chart) As Boolean
Dim i As Integer
Dim j As Integer
Dim objSeries As Series
' Loop through all series of data within the chart
For i = 1 To chtAnalyse.SeriesCollection.Count
Set objSeries = chtAnalyse.SeriesCollection(i)
' Loop through each value of the series
For j = 1 To UBound(objSeries.Values)
' If we have a non-zero value then the chart is not deemed to be empty
If objSeries.Values(j) <> 0 Then
' Set return value and quit function
IsChartEmpty = False
Exit Function
End If
Next j
Next i
IsChartEmpty = True
End Function
Change the object passed to the function from Chart to full ChartObjectlike this:
Private Sub HideEmptyCharts()
Dim wksCharts As Worksheet
Dim objCO As ChartObject
Set wksCharts= ThisWorkbook.Sheets("Report output")
For Each objCO In wksCharts.ChartObjects
objCO.Visible = True
If IsChartEmpty(objCO) Then objCO.Visible = False
Next objCO
End Sub
Private Function IsChartEmpty(co As ChartObject) As Boolean
Dim i As Integer
Dim j As Integer
Dim objSeries As Series
For i = 1 To co.Chart.SeriesCollection.Count
Set objSeries = co.Chart.SeriesCollection(i)
For j = 1 To UBound(objSeries.Values)
If objSeries.Values(j) <> 0 Then
IsChartEmpty = False
Exit Function
End If
Next j
Next i
IsChartEmpty = True
End Function
An outdated pivotcache and some still remembered but in the meantime missed items caused some trouble to me in the past. So I propose to add this code once before:
Dim pc As PivotCache
For Each pc In ThisWorkbook.PivotCaches
pc.MissingItemsLimit = xlMissingItemsNone
pc.Refresh
Next pc
Requirement:
We have a chart with a considerable cardinality in filters. User wants to single-click print all permutations.
My idea:
Iterate all, setting the filters and rendering the chart as image to a single sheet (unfortunately, I haven't found a way to do it w/o using clipboard).
Solution:
#If VBA7 Then
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) 'For 64 Bit Systems
#Else
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'For 32 Bit Systems
#End If
Sub PrintButton_Click()
Dim ps As Worksheet
Dim gs As Worksheet
Dim r As Range
Dim c As ChartObject
Dim s As Shapes
Dim n As Integer
Application.ScreenUpdating = False
Set gs = Sheets("Graph")
Set ps = gs
Set c = gs.ChartObjects("Chart")
n = 0
For Each loopRow In Sheets("Klassen").UsedRange.Rows
' there seems to be 1024 PageBreaks per Sheet limit
If n Mod 1024 = 0 Then
Set ps = Sheets.Add(After:=ps)
ps.Name = "Print" + IIf(n / 1024 = 0, "", "_" + CStr(n / 1024))
ps.PageSetup.Orientation = xlLandscape
Set s = ps.Shapes
Set r = ps.Cells(1, 1)
End If
If loopRow.Row <> 1 And loopRow.Cells(1).Value <> "" And loopRow.Cells(2).Value <> "" Then
gs.Cells(1, 2).Value = loopRow.Cells(1).Value
gs.Cells(2, 2).Value = loopRow.Cells(2).Value
c.CopyPicture
DoEvents
'Sleep 1000
'DoEvents
'EnsureClipboard (xlClipboardFormatPICT)
'dbg = Application.ClipboardFormats(1)
r.PasteSpecial
'ps.Paste Destination:=r
Set r = ps.Cells(s(s.Count).BottomRightCell.Row + 1, 1)
r.PageBreak = xlPageBreakManual
'gs.Cells(1, 1).Copy
'EnsureClipboard (xlClipboardFormatText)
End If
n = n + 1
Next
gs.Cells(1, 2).Value = "(All)"
gs.Cells(2, 2).Value = "(All)"
Application.ScreenUpdating = True
End Sub
Sub EnsureClipboard(desiredFmt As XlClipboardFormat)
Dim present As Boolean
DoEvents
present = False
Do While Not present
aFmts = Application.ClipboardFormats
For Each fmt In aFmts
If fmt = desiredFmt Then
present = True
End If
Next
If Not present Then
DoEvents
Sleep 100
DoEvents
End If
Loop
End Sub
Problem:
After a variable amount of iterations, Excel throws "Run-time error '1004' PasteSpecial method of Range class failed".
Debug:
Both "r.PasteSpecial" and "ps.Paste Destination:=r" fails.
dbg variable contains xlClipboardFormatPICT, so it seems the data is there and inspecting the clipboard confirms it.
I was even desperate enough to wait a whole second between copying and pasting to eliminate the race condition - paste typically fails after pretty much the same number of successes.
I'm using Office 365 ProPlus. Funny thing is it used to work on v1705, it fails on v1803. Even funnier is that for some time after the upgrade it worked, so I'm not sure if it would still work on previous version...
I had been running a cut and paste picture routine for some time and all of a sudden Excel starting giving me this run time error. It had been working fine for several days until now (no OS update or reboot, though I did try closing and reopening Excel to see if it helped). Stranger still, the script does a batch copy and paste.picture, the same range (with recalculated values) is copied and pasted 13 times and the error message pops up usually in the last loop or occasionally at some random point.
I looked up support.microsoft.com/en-us/kb/905164:
"This issue may occur if either of the following conditions is true:
The Microsoft Visual Basic for Applications (VBA) macro copies and pastes one whole row in an Excel 2003 workbook.
The Microsoft VBA macro copies and pastes a range of 2,516 rows or more rows in an Excel 2003 workbook."
However, I am copying a range of 12,12 cells, from A1 to L12 to be exact, not even close to an entire row. I have tried using range.offset, xldown, rannge(cells(1,1), cells(12,12)) but none of these helped.
Has anyone experienced something similar?
Sub PutPic(ByRef FN As String)
Dim fname As String
fname = "E:\Users\ABCD\Documents\EFGH\" & FN
Worksheets(2).Range(Cells(1, 1), Cells(12, 12)).Select
'Sheets("sheet2").Range("A1:l12").Select
Selection.Copy
'Sheets("sheet2").Range("a1").Select
ActiveSheet.Pictures.Paste(Link:=False).Select
Selection.Name = "Pic"
Selection.ShapeRange.ScaleWidth 2, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 2, msoFalse, msoScaleFromMiddle
Dim ChtObj As ChartObject
With ThisWorkbook.Worksheets(2)
.Activate
Set ChtObj = .ChartObjects.Add(100, 100, 400, 400)
ChtObj.Name = "PicFrame"
ChtObj.Width = .Shapes("Pic").Width
ChtObj.Height = .Shapes("Pic").Height
ActiveSheet.Shapes.Range(Array("Pic")).Select
Selection.Copy
ActiveSheet.ChartObjects("PicFrame").Activate
ActiveChart.Paste
ActiveChart.Export Filename:=fname, FilterName:="png"
ChtObj.Delete
ActiveSheet.Shapes.Range(Array("Pic")).Delete
End With
End Sub
The sub with the looping routine, totally ordinary which feeds a filename to the subroutine.
Public Sub MainRun()
Dim i, j, k As Long
Dim NMG, NMB As String
Dim FNGBSig As String
Dim FNUnivSig As String
Dim BatchStart, Batch As Long
BatchStart = ThisWorkbook.Worksheets(2).Cells(15, 1).Value + 1
Batch = 13
For i = BatchStart To BatchStart + Batch - 1
'Some calculations that refresh values in range A1:L12
FNGBSig = i & "GoodBad.png"
PutPic FNGBSig
Next i
End Sub
I suspect the loop is causing the issue as the .Export method is running in to itself. Use the WinAPI Sleep function to insert a small delay (1 second is probably enough). Also, I've cleaned up the code a little bit:
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'For use in timer function
Sub PutPic(FN)
Dim fname As String
Dim shp As Picture
Dim ChtObj As ChartObject
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(2)
fname = "E:\Users\ABCD\Documents\EFGH\" & FN
'Copy the range of cells
With ws
.Range(.Cells(1, 1), .Cells(12, 12)).Copy
'Paste & get a handle on the resulting picture:
Set shp = .Pictures.Paste(Link:=False)
End With
'Scale your picture:
With shp
.ShapeRange.ScaleWidth 2, msoFalse, msoScaleFromTopLeft
.ShapeRange.ScaleHeight 2, msoFalse, msoScaleFromMiddle
End With
'Add the ChtObj frame:
Set ChtObj = ws.ChartObjects.Add(100, 100, 400, 400)
'Size the chart, paste the picture in the chart, export
With ChtObj
.Width = shp.Width
.Height = shp.Height
shp.Copy
Sleep 1000 '1000 milliseconds = 1 second
.Chart.Paste
.Chart.Export Filename:=fname, FilterName:="png"
.Delete
End With
shp.Delete
End Sub
Note that this is generally frowned upon:
Dim i, j, k As Long
Dim NMG, NMB As String
Dim FNGBSig As String
Dim FNUnivSig As String
Dim BatchStart, Batch As Long
This declares i as Variant, j as Variant, k as Long, etc. To do multiple declarations inline, you still need to specify the data type:
Dim i as Long, j as Long, k as Long
Dim NMG as String, NMB as String
' etc...