I am trying to create a dashboard that allows the user to opt for either Line or Stacked area chart. The color codes for each of the label(category) is already pre-decided. The code for chart formatting works fine for the Line chart. However, it doesn't when i opt for Stacked-Area chart visualization. Below is the code for Line chart:
Public Function ChartSeriesFormat()
Dim objDictChartColor As Object
Dim varChartColor As Variant
Dim rngChartColor As Range
Dim objSalesChart As Chart
Dim rngTemp As Range
Dim strSeriesName As String
Dim lngStartRow As Long
Dim lngColor As Long
Dim lngItem As Long
' --> Assign objects
Set objSalesChart = shtOutput.ChartObjects("chtMarketShare").Chart
varChartColor = shtMapping.Range("rng_ChartColor").CurrentRegion
Set rngChartColor = shtMapping.Range("rng_ChartColor").CurrentRegion
Set objDictChartColor = CreateObject("Scripting.Dictionary")
For lngItem = 1 To UBound(varChartColor, 1)
If Not objDictChartColor.exists(LCase(varChartColor(lngItem, 1))) Then
objDictChartColor.Add LCase(varChartColor(lngItem, 1)), rngChartColor.Cells(lngItem, 1).Interior.Color
End If
Next lngItem
lngStartRow = shtOutput.Range("rng_OutputDB1").CurrentRegion.Rows.Count
For lngItem = 1 To objSalesChart.SeriesCollection.Count
With objSalesChart
'Make all the lines in the series xlcontinous
.SeriesCollection(lngItem).Border.LineStyle = xlContinuous
strSeriesName = LCase(.SeriesCollection(lngItem).Name)
lngColor = objDictChartColor.Item(strSeriesName)
.SeriesCollection(lngItem).Border.Color = lngColor
End With
Next
On Error Resume Next
With shtOutput.Range("rng_OutputDB2")
If .Offset(1).Value <> "" Then
Set rngTemp = .CurrentRegion.SpecialCells(xlCellTypeVisible)
End If
End With
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0: On Error GoTo -1
GoTo ClearMemory
End If
Err.Clear: On Error GoTo 0: On Error GoTo -1
For lngItem = lngStartRow To objSalesChart.SeriesCollection.Count
With objSalesChart
'Make all the lines in the series xlcontinous
.SeriesCollection(lngItem).Border.Color = objSalesChart.SeriesCollection(lngItem - (lngStartRow - 1)).Border.Color
.SeriesCollection(lngItem).Border.LineStyle = xlDot
End With
Next
ClearMemory:
End Function
The option to choose "Stacked-Area" chart was added later. Any help?
Related
I'm in a bit of a trap with my code. I'm trying to delete charts that occupy the same merged cell, but I'm getting an error. The code wont compile for each ScrapChart in AllChartsInBox() if scrapchart isn't set as variant, but then I get Run-time error 91 trying to run ScrapChart.delete.
Why Does Scrapchart have to be set as variant, but SheetChart works fine in the For Each SheetChart In Ws_Charts.ChartObjects loop when it's been set as a ChartObject?
option explicit
Dim NumberofChartsinRange, ChartBoxIndex As Long
Dim SheetChart, AllChartsInBox() As ChartObject
Dim ScrapChart As Variant
Set Chartbox = Ws_Charts.Range("A1:F6")
Ws_Charts.Cells(1,1).Formula2 = formulastring
Chartbox.Merge
Chartbox.HorizontalAlignment = xlRight
Chartbox.VerticalAlignment = xlBottom
NumberofChartsinRange = 0
If Ws_Charts.ChartObjects.Count = 0 Then
Else
ReDim AllChartsInBox(Ws_Charts.ChartObjects.Count - 1)
For Each SheetChart In Ws_Charts.ChartObjects
If Not Intersect(SheetChart.TopLeftCell, Chartbox) Is Nothing Then
NumberofChartsinRange = NumberofChartsinRange + 1
Set AllChartsInBox(ChartBoxIndex) = SheetChart: ChartBoxIndex = ChartBoxIndex + 1
End If
Next
End If
If NumberofChartsinRange > 1 Then
For Each ScrapChart In AllChartsInBox
ScrapChart.Delete
Next ScrapChart
End If
You can do this in a single pass through the ChartObjects collection:
Dim SheetChart, co As ChartObject, ChartBox As Range
Dim tmp As ChartObject, foundOne As Boolean, i As Long
Set ChartBox = Ws_charts.Range("A1:F6")
Ws_charts.Cells(1, 1).Formula2 = formulastring
ChartBox.Merge
ChartBox.HorizontalAlignment = xlRight
ChartBox.VerticalAlignment = xlBottom
For i = Ws_charts.ChartObjects.Count To 1 Step -1
Set co = Ws_charts.ChartObjects(i)
If Not Intersect(co.TopLeftCell, ChartBox) Is Nothing Then
If Not foundOne Then 'first chart found?
Set tmp = co
foundOne = True
Else
'multiple charts - delete the first one and this one...
If Not tmp Is Nothing Then tmp.Delete
co.Delete
End If
End If
Next i
I want to check the status of a sheet and when changed automatically run some calculations. I also wish refresh a graph with the new data from that sheet.
I used the Worksheet_Change function. It calls the sub with the calculations and calls the sub that contains the chart modification code. They run as planned with one exception. The range that gets passed to the Chrt1 sub (responsible for the chart functionality) does not get updated on the graph once it has been called out for the first time.
I'm aware that this can be overcome with Excel built-in tables function but I'd like to code this simple routine in anyways.
The Worksheet_Change function:
Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
AutoChangeTest
Application.EnableEvents = True
End Sub
The main module code:
Sub AutoChangeTest()
Dim s1 As Worksheet, s2 As Worksheet
Dim i As Integer, j As Integer, lrow As Integer, lrow2 As Integer
Set s1 = Sheets("Arkusz3")
On Error GoTo Err1
lrow = s1.Cells(s1.Rows.Count, 1).End(xlUp).Row
For i = 1 To lrow
s1.Cells(i, 2) = s1.Cells(i, 1) * 2
Next
Call Chrt1(Range(s1.Cells(1, 1), s1.Cells(lrow, 2)), s1)
Err1:
If Not IsNumeric(s1.Cells(i, 1)) Then
s1.Cells(i, 1).Activate
End If
End Sub
Sub Chrt1(r1 As Range, s1 As Worksheet)
Dim c1 As Shape
Dim s As Worksheet
Dim cht As ChartObject
Dim i As Integer
i = 0
Set r = r1
Set s = s1
For Each cht In s.ChartObjects
i = i + 1
Next
If i = 0 Then
Set c1 = s.Shapes.AddChart
End If
c1.Chart.SetSourceData (r)
End Sub
Some suggestions in the code below:
Sub AutoChangeTest()
Dim ws As Worksheet 'avoid variable names with 1/l - too unclear
Dim i As Long, lrow As Long 'always use long over integer
Set ws = ThisWorkbook.Worksheets("Arkusz3")
lrow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
On Error GoTo exitHere
Application.EnableEvents = False 'don't re-trigger this sub...
For i = 1 To lrow
With ws.Cells(i, 1)
'easier to test than to trap an error if non-numeric
If IsNumeric(.Value) Then
ws.Cells(i, 2) = .Value * 2
Else
ws.Select
.Select
MsgBox "Non-numeric value found!"
GoTo exitHere 'acceptable use of Goto I think
End If
End With
Next
'don't think you need a separate method for this...
If ws.ChartObjects.Count = 0 Then ws.Shapes.AddChart 'no need to loop for a count
'assuming there will only be one chart...
ws.ChartObjects(1).Chart.SetSourceData ws.Range(ws.Cells(1, 1), ws.Cells(lrow, 2))
exitHere:
If Err.Number <> 0 Then Debug.Print Err.Description
Application.EnableEvents = True
End Sub
In your Chrt1 procedure, this bit
For Each cht In s.ChartObjects
i = i + 1
Next
If i = 0 Then
Set c1 = s.Shapes.AddChart
End If
can be replaced by the following:
If s.ChartObjects.Count = 0 Then
Set c1 = s.Shapes.AddChart
End If
But what is c1 if you don't have to add a chart? You haven't defined it, and the On Error means you never find out that it's broken.
Assuming you want the last chart object to be the one that is changed:
If s.ChartObjects.Count = 0 Then
Set c1 = s.Shapes.AddChart
Else
Set c1 = s.ChartObjects(s.ChartObjects.Count)
End If
And you should declare c1 as a ChartObject.
Finally, remove the parentheses around r in this line:
c1.Chart.SetSourceData r
Thank you all for support. The basic code that works is shown below. It isn't the best looking but it does the job.
Sub Chrt1(r1 As Range, s1 As Worksheet)
Dim c1 As Shape
Dim s As Worksheet
Dim cht As ChartObject
Dim i As Integer
i = 0
Set r = r1
Set s = s1
For Each cht In s.ChartObjects
i = i + 1
Next
If i = 0 Then
Set c1 = s.Shapes.AddChart
End If
Set cht = s.ChartObjects(1)
cht.Chart.SetSourceData Source:=r
End Sub
When I try and copy and paste shapes in Excel, I get a debug message telling me there is a
1004 error - Copy Method of Picture Class Failed
When I then press continue in the macro, it works? I tried adding an Application.Wait(5) statement to add a delay in, but the same thing happens. I tried adding DoEvents between the Copy and Paste, but it didn't help.
Public Sub PlotApprovals()
Dim lngRow As Long
Dim lngCol As Long
Dim strCountry As String
Dim datEmergencyUseApproval As Date
Dim rngSyringe As Range
Dim intCountryCols As Integer
Dim intColCount As Integer
Dim shpCopy As Shape
Dim shpPaste As Shape
Dim intShapeIndex As Integer
intCountryCols = 1
intColCount = 4
lngCol = 4
DeleteShapes
For intColCount = 1 To 4
If intColCount = 1 Then
lngCol = 4
ElseIf intColCount = 2 Then
lngCol = 9
ElseIf intColCount = 2 Then
lngCol = 14
ElseIf intColCount = 2 Then
lngCol = 19
End If
For lngRow = 3 To 42
Set rngSyringe = shtDashboard.Cells(lngRow, lngCol + 1)
strCountry = shtDashboard.Cells(lngRow, lngCol)
datEmergencyUseApproval = Application.WorksheetFunction.VLookup(strCountry, shtData.Range("A:X"), 24, False)
If datEmergencyUseApproval <> 0 Then
Set shpCopy = shtDashboard.Shapes("syringeEmergencyUse")
shpCopy.Copy
shtDashboard.Paste
intShapeIndex = idxLastShape("Dashboard")
Set shpCopy = shtDashboard.Shapes(intShapeIndex)
shpCopy.Name = "syringe"
shpCopy.Left = rngSyringe.Left
shpCopy.Top = rngSyringe.Top
End If
Next lngRow
Next intColCount
End Sub
Public Sub DeleteShapes()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
If shp.Name = "syringe" Then
shp.Delete
End If
Next shp
End Sub
Function idxLastShape(shtName As String) As Long
Dim sh As Shape
For Each sh In Sheets(shtName).Shapes
idxLastShape = idxLastShape + 1
Next sh
End Function
----------UPDATE-------------
If the main copy and paste logic is updated as below, I now get a Copy of Object Shape failed error. It takes me into Debug, where if I proceed it works. So the failure is at runtime, but it works in debug mode when I step through.
Set shpCopy = shtDashboard.Shapes("syringeEmergencyUse")
shpCopy.Select
shpCopy.Copy
rngSyringe.Select
shtDashboard.Paste
intShapeIndex = idxLastShape("Dashboard")
Set shpCopy = shtDashboard.Shapes(intShapeIndex)
shpCopy.Name = "syringe"
shpCopy.Left = rngSyringe.Left
shpCopy.Top = rngSyringe.Top
GreenCell rngCountry
The issue appears when you shtDashboard.Paste and there is a shape selected and not a cell. Make sure you select a cell before pasting:
shpCopy.Select
shpCopy.Copy
shtDashboard.Range("A1").Select 'select a cell to ensure no shape is selected
shtDashboard.Paste
The solution it seems is to add this after the copy, must be a timing issue:
shp.Copy
Application.Wait(Now+TimeSerial(0,0,2))
DoEvents
rngSyringe.Select
ActiveSheet.Paste
I have a chart with 2 data series that reference cell values with conditional formatting to determine its color. I looked up a VBA code on the net to use on the chart to update the colors of the series based on the cell color, but when running the code nothing happens.
Anybody can help me with this?
Sub CellColorsToChart()
'Updateby Extendoffice
Dim xChart As Chart
Dim I As Long, J As Long
Dim xRowsOrCols As Long, xSCount As Long
Dim xRg As Range, xCell As Range
On Error Resume Next
Set xChart = ActiveSheet.ChartObjects("Chart 2").Chart
If xChart Is Nothing Then Exit Sub
xSCount = xChart.SeriesCollection.Count
For I = 1 To xSCount
J = 1
With xChart.SeriesCollection(I)
Set xRg = ActiveSheet.Range(Split(Split(.Formula, ",")(2), "!")(1))
If xSCount > 4 Then
xRowsOrCols = xRg.Columns.Count
Else
xRowsOrCols = xRg.Rows.Count
End If
For Each xCell In xRg
.Points(J).Format.Fill.ForeColor.RGB = ThisWorkbook.Colors(xCell.Interior.ColorIndex)
.Points(J).Format.Line.ForeColor.RGB = ThisWorkbook.Colors(xCell.Interior.ColorIndex)
J = J + 1
Next
End With
Next
End Sub
xCell.Interior references the cells applied color, not a conditional format.
If you are using Excel 2010+ then you should use .DisplayFormat to get the conditional format color.
Also, why bother with ThisWorkbook.Colorsand ColorIndex, just reference the color:
.Points(J).Format.Fill.ForeColor.RGB = xCell.DisplayFormat.Interior.Color
Also, after you set On Error Resume Next to trap an error on Set xChart =, you must reset the error handling
On Error Resume Next
Set xChart = ActiveSheet.ChartObjects("Chart 2").Chart
On Error GoTo 0 ' <~~ reset error handling
If xChart Is Nothing Then Exit Sub
Can anyone Please help resolve an issue with ReferToRange in my code. I have attached an example.
I am getting a runtime error 1041 application defined or object defined error when the MAIN is called.
I am linking a combobox listfillrange to 3 named ranges depending on the value of a cell. The three ranges are dynamic(have an offset formula).
the combobox is a different sheet than the named ranges
Please help
Sub MAIN()
Dim PT As Range
Dim i As Long
With Sheet3 ' Unique SPP
setNames .Range("a6")
Set PT = .Range("b1")
i = 1
Do Until PT = ""
If .Range("a1").Value = PT.Value Then
On Error Resume Next
Sheet1.ComboBox1.ListFillRange = ThisWorkbook.Names("view" & i).Name
If Err.Number = 1004 Then
MsgBox "not defined name: view" & i
ElseIf Err.Number <> 0 Then
MsgBox "unexpected error: " & Err.Description
End If
On Error GoTo 0
End If
i = i + 1
Set PT = PT.Offset(0, 1)
Loop
End With
End Sub
Sub setNames(theTopLeft As Range)
Dim theName As Name
Dim nameStr As String
Dim theRng As Range
Dim i As Long
Application.DisplayAlerts = False
theTopLeft.CurrentRegion.CreateNames Top:=True, Left:=False, _
Bottom:=False, Right:=False
Application.DisplayAlerts = True
For Each theName In ThisWorkbook.Names
With theName.RefersToRange.Value
For i = .Cells.Count To 1 Step -1
If .Cells(i) <> "" Then Exit For
Next
End With
If i <> 0 Then theName.RefersTo = theName.RefersToRange.Resize(i, 1)
Next
End Sub
It seems to me that your code is a bit more complicated than necessary. So if I'm understanding correctly what you're trying to do, this should fit the bill.
Sub MAIN()
Dim rC As Range
Dim rD As Range
Dim i As Long
Dim s As String
On Error GoTo errTrap
With Sheet3 'change to suit
s = .Range("a1") 'heading to find
Set rD = .Range("A6", .Cells.SpecialCells(xlCellTypeLastCell)) 'data row 6 and down
Set rD = rD.Resize(, 3) '1st 3 columns only, change if required
i = Application.Match(s, rD.Rows(1).Cells, 0) 'find heading
Set rC = rD.Columns(i).Offset(1).Cells 'drop heading from column
Set rC = .Range(rC(1), .Cells(.Rows.Count, rC.Column).End(xlUp)) 'to end of data
' if column contains data, fill combo
If rC(1).Row > rD.Row Then Sheet1.ComboBox1.ListFillRange = .Name & "!" & rC.Address
End With
Exit Sub
errTrap:
If Err.Number = 13 Then
MsgBox "heading not found: " & s
Else
MsgBox "unexpected error: " & Err.Description
End If
End Sub