I am trying to extract data from MS-excel graph using macro given on MS excel website
Here is the code
Sub GetChartValues()
Dim NumberOfRows As Integer
Dim X As Object
Counter = 2
' Calculate the number of rows of data.
NumberOfRows = UBound(ActiveChart.SeriesCollection(1).Values)
Worksheets("ChartData").Cells(1, 1) = "X Values"
' Write x-axis values to worksheet.
With Worksheets("ChartData")
.Range(.Cells(2, 1), _
.Cells(NumberOfRows + 1, 1)) = _
Application.Transpose(ActiveChart.SeriesCollection(1).XValues)
End With
' Loop through all series in the chart and write their values to
' the worksheet.
For Each X In ActiveChart.SeriesCollection
Worksheets("ChartData").Cells(1, Counter) = X.Name
With Worksheets("ChartData")
.Range(.Cells(2, Counter), _
.Cells(NumberOfRows + 1, Counter)) = _
Application.Transpose(X.Values)
End With
Counter = Counter + 1
Next
End Sub
Where is the error in this code?
VB Complier will not know which ActiveChart you are talking about. Hence you need to set the chart object first and then try to use it.
Check this code:
Dim mychart As ChartObject
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
Set mychart = ws.ChartObjects("Chart 1")
With mychart.Chart
'do stuff here
End With
Related
I have items that are being populated on a worksheet via userform. When I open the workbook I'm trying to get the tool to go to the sheet grab the data and generate a chart/dashboard on the main landing sheet.
In the range of data contains statuses. I want VBA to look through one column of data and create a chart that counts each different status and put that in a bar chart.
yaxis = the different statuses
xaxis = count
my code so far
Sub populatecharts()
Dim ws As Worksheet
Dim ch As Chart
Dim tablerng As Range
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range
Dim sh As String
Set ws = ActiveSheet
'When the workbook opens it should always check the data and populate the BA Dashboard
'I need to check for sheets and if they exist generate a chart from the data
sh = "Action"
On Error Resume Next
Worksheets("Action").Visible = True
If CheckSheetExist(sh) = False Then
GoTo nextchart1
Else
Worksheets(sh).Activate
'Set ws = ActiveSheet
Set rng1 = Range("G4", Range("G4", "G4").End(xlDown))
rng1.Select
'Set rng2 = Range("B2")
'Set rng3 = Range("C3")
'Set tablerng = rng1 '& rng2 & rng3
Set ch = ws.Shapes.AddChart2(Width:=200, Height:=200, Left:=Range("B4").Left, Top:=Range("B4").Top).chart
With ch
.SetSourceData Source:=rng1
.ChartType = xlBarClustered
.ChartTitle.Text = "Action Items by Status"
End With
ws.Activate
Worksheets("Action").Visible = False
End If
Seems easy but I'm not able to think through it, also the location is hit or miss even though I define the top and bottom and size. Sometimes it's to the right of the cell I chose to be the left.
Try the next way, please. It uses a dictionary to extract the unique values and their count and array to feed the necessary series. Try running it on active sheet and adapt it to your situation only after having the confirmation that what it returns is what you need:
Sub populatecharts()
Dim shT As Worksheet, ch As Chart, lastRow As Long
Dim arrY, arrX, i As Long, dict As Object
Set shT = ActiveSheet 'use here the sheet you need
lastRow = shT.Range("G" & shT.Rows.count).End(xlUp).row
arrX = shT.Range("G4:G" & lastRow).Value 'put the range in a array
Set dict = CreateObject("Scripting.Dictionary") 'needed for the next step
On Error Resume Next
shT.ChartObjects("MyChartXY").Delete 'for the case of re running need
On Error GoTo 0
For i = 1 To UBound(arrX)
If Not dict.Exists(arrX(i, 1)) Then
dict(arrX(i, 1)) = 1 'create the unique keys
Else
dict(arrX(i, 1)) = dict(arrX(i, 1)) + 1 'increment the key next occurrrence
End If
Next i
arrX = dict.Keys: arrY = dict.Items 'extract the necessary arrays
Set ch = shT.ChartObjects.Add(left:=shT.Range("B4").left, _
top:=shT.Range("B4").top, width:=200, height:=200).Chart
With ch
.ChartType = xlBarClustered
.HasTitle = True
.ChartTitle.Text = "Action Items by Status"
.SeriesCollection.NewSeries.Values = arrY 'feed it with the array elements
.SeriesCollection(1).XValues = arrX 'feed it with the array elements
End With
End Sub
Please, test it and send some feedback.
I have created a macro which creates line chart for each row. Below is the code.
The data is in following format:
Format in which I have the data:
Sub createChartWithLoop()
Dim wks As Worksheet
Set wks = Worksheets("Sheet1")
Dim chrt As Chart
Set chrt = wks.Shapes.AddChart.Chart
Dim chartRange As Range
Set chartRange = wks.Range("A1:A4")
With chrt
.ChartType = xlLine
.SetSourceData Source:=Range(wks.Range("A" & chartRange.Row & ":D" & chartRange.Row).Address)
For i = chartRange.Row + 1 To chartRange.Rows.Count
.SeriesCollection.NewSeries
.SeriesCollection(i).Name = wks.Cells(i, 1)
.SeriesCollection(i).Values = wks.Range("B" & i & ":D" & i)
Next i
End With
End Sub
However, now I have a little different requirement. Assume I have 30 rows same format.
Requirement: I have to consider the first 3 rows as 1 set. 2nd 3 rows as 2nd Set and so on. So here effective we will have 10 set (30 rows/3). Each set should give me a chart.
Right now, I'm getting a chart with 3 lines (3 records). Above is my code. Can anyone help on the above request?
I wrote a procedure which will plot a stated number of charts each using a stated number of rows. Then I wrote a short procedure that shows how to have it create 10 charts with three rows each.
Here is the procedure to create nCharts charts, using nRows rows for each:
Sub CreateChartWithLoop(nCharts As Long, nRows As Long)
Dim wks As Worksheet
Set wks = ActiveSheet
Dim DataRange As Range
Set DataRange = ActiveSheet.UsedRange
Dim iChart As Long
For iChart = 1 To nCharts
Dim cht As Chart
Set cht = wks.Shapes.AddChart(xlLine, DataRange.Width, DataRange.Rows(1 + (iChart - 1) * nRows).Top).Chart
Do Until cht.SeriesCollection.Count = 0
cht.SeriesCollection(1).Delete
Loop
Dim iRow As Long
For iRow = 1 To nRows
With cht.SeriesCollection.NewSeries
.Name = "=" & DataRange.Cells(iRow + (iChart - 1) * 3, 1).Address(, , , True)
.Values = DataRange.Rows(iRow + (iChart - 1) * 3).Offset(, 1).Resize(, DataRange.Columns.Count - 1)
End With
Next
cht.HasTitle = True
cht.ChartTitle.Text = "Chart " & iChart
Next
End Sub
Here's the procedure that calls the main procedure, telling it to make 10 charts with 3 rows each:
Sub Create10ChartsWith3RowsEach()
CreateChartWithLoop 10, 3
End Sub
I've been trying to search for days already for solutions or idea how to do this in Excel VBA, however I cannot find a similar scenario for my needs.
Here's the idea:
I have the following table as reference for the hyperlinks:
Now on a separate column, I want to create a "+" shape in each corresponding next column of the reference number and make each shape a hyperlink in reference to the first image provided. It may contain one or more shapes in one cell until all the links for that reference number has been made.
I want to do this in VBA because multiple links in single cell is not possible in Excel and hence shape/image/symbol hyperlinking is the only solution I can think of. I am clueless where to start or how to start.
I hope someone will be able to direct me as I am still learning on Excel VBA. Thank you in advance.
Set reference Microsoft Scripting Runtime
Sub SetHyperlinkOnShape()
' reference Microsoft Scripting Runtime
Dim ws As Worksheet, ws2 As Worksheet, dict As dictionary
Dim tKey(0) As Variant
Dim LRandomNumber As Integer
Set ws = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
Application.ScreenUpdating = False
DeleteAllShapes ws2
Dim hyperLinkedShape As Shape
Dim t As Range
ColumnToPasteNumber = 2 ' on Sheet2 Column B
ColumnAlpha = "A" ' Column Latter from SHeet1 in your case H
LastRow = ws.Cells(ws.Rows.Count, ColumnAlpha).End(xlUp).Row ' get last row
Set dict = CreateObject("Scripting.Dictionary") ' put all unique value to dictionary
Set Rng = ws.Range(ws.Cells(1, 1), ws.Cells(LastRow, 2))
For ci = 1 To LastRow ' change 1 to 2 in your case to start from second row as you have headers
strName = Rng(ci, 1)
strLink = Rng(ci, 2)
If dict.Exists(strName) Then
Dim tempArr() As Variant
tempArr() = dict(strName)
sCount = UBound(tempArr) + 1
ReDim Preserve tempArr(0 To sCount)
tempArr(sCount) = strLink
dict(strName) = tempArr
Else
tKey(0) = strLink
dict.Add strName, tKey
End If
Next ci
For Each UniqueVal In dict ' loop dictionary to paste to cells
i = i + 1
Set t = ws2.Range(ws2.Cells(i, ColumnToPasteNumber), ws2.Cells(i, ColumnToPasteNumber))
NumbersOfPluses = UBound(dict(UniqueVal)) + 1
sw = t.Width / NumbersOfPluses
ws2.Cells(i, 1).Value = UniqueVal
For y = 1 To NumbersOfPluses ' set default shape width sw
sw = t.Height 'in points
sL = t.Left + sw * (y - 1)
If y = 1 Then sL = t.Left
Set hyperLinkedShape = ws2.Shapes.AddShape(msoShapeMathPlus, sL, t.Top, sw, t.Height)
hyperLinkedShape.Placement = xlFreeFloating ' do not size and dont move
strLink = dict(UniqueVal)(y - 1)
strHint = "Click ME"
ws2.Hyperlinks.Add Anchor:=hyperLinkedShape, Address:=strLink, SubAddress:="", ScreenTip:=strHint
Next y
If getMaxCellWidth < t.Height * NumbersOfPluses Then getMaxCellWidth = t.Height * NumbersOfPluses
Next UniqueVal
' ColumnWidth in units !!!
ws2.Columns("B:B").ColumnWidth = (((getMaxCellWidth) / 0.75 - 5) / 7) ' convert points to units
Application.ScreenUpdating = True
End Sub
Sub DeleteAllShapes(ws As Worksheet)
Dim shp As Shape
For Each shp In ws.Shapes
shp.Delete
Next shp
End Sub
This is the thing: I do have an energy model. The outcome is data (Watt) of the losses of energy by wall, floor, windows, ventilation, roof. The changing part in my model is the outside temperature. I did write a macro which changes this temperature from -10 to 10 Celcius. In a normal pie-chart this works nicely. So the temperature field changes and the values for wall, floor etc are updated in their respective fields.
But this is what I need: I want a graph (line or scatter) that will display: temperature (x-axis) and power (Watt, y-axis) for all 5 (wall, floor, etc) places where I lose energy.
How to do this? Can i (do i have to) collect the data and then at the end present it in a graph? Or can i tell excel to extend the graph with each new values when temperature is changed? At this point i can only display the actual data in the fields more or less.
I hope you understand my question and that someone can point me in the right direction.
This is the code I came up with so far:
Sub BtnBuitenTemp()
Dim PauseTime, Start
Dim ws1 As Worksheet
Set ws1 = Sheets(1)
Dim ws2 As Worksheet
Set ws2 = Sheets(2)
Dim cell As Range
' loop through temperature values given on Sheet(2)
' for now these range from -10 to 10
For Each cell In ws2.Range("A20:A40")
' update values in temperature cell
ws1.Cells.Range("D10").Value = cell.Value
' add some pause
PauseTime = 1
Start = Timer
Do While Timer < Start + PauseTime
DoEvents
Loop
Next
End Sub
And a screenshot:
The orange part in "Temperaturen" is changed by the macro. Thereby all other data will be updated and displayed in the chart. The chart will only update the y-axis values at this point. I would like to loop the temperature range (and display this as well on the x-axis) and keep the former values in the chart at their respective temperatures. (I also am not able to display the x-axis range.)
(update)
Ok, I do have a XY (scatter) graph now and I can set the x axis. This is what I do have so far:
Sub BtnBuitenTemp()
Dim PauseTime, Start
Dim tbu_min As Integer
Dim tbu_max As Integer
Dim ws1 As Worksheet
Set ws1 = Sheets(1)
' get user values for min and max temp
tbu_min = ws1.Range("TempBuitenMin").Value
tbu_max = ws1.Range("TempBuitenMax").Value
' set chart x axis values to user input
With ws1.ChartObjects("Chart 7").Chart
With .Axes(xlCategory)
.MinimumScale = tbu_min
.MaximumScale = tbu_max
End With
End With
For temp = tbu_min To tbu_max
' update values in temperature cell
ws1.Cells.Range("D10").Value = temp
' add some pause
PauseTime = 0.5
Start = Timer
Do While Timer < Start + PauseTime
DoEvents
Loop
Next temp
End Sub
And that looks like:
Now I only need to update the data on the right temperature...
update 2 -
I updated my data for the xy scatter graph. I forgot to insert the "Series X Values". Now the right is displayed at the right temperature. I now only need to keep the output in view; at this moment it does refresh the graph each time.
Well, I did solve my problem. Not the way I wanted it, but I do not have time left to find another way. I now just collect all the data and draw a chart from within my macro. This is a prototype that does the trick.
Sub BtnBuitenTemp()
Dim PauseTime, Start
Dim tbu_min As Integer
Dim tbu_max As Integer
Dim ws1 As Worksheet
Set ws1 = Sheets(1)
Dim dataSize As Integer
Dim dataCounter As Integer
Dim myChartObject As ChartObject
Dim addTotal As Boolean
' get user values for min and max temp
tbu_min = ws1.Range("TempBuitenMin").Value
tbu_max = ws1.Range("TempBuitenMax").Value
' how many datapoints are there
Dim xPoints() As Integer
' add surfaces
Dim muur() As Integer
Dim vloer() As Integer
Dim ramen() As Integer
Dim dak() As Integer
Dim ventilatie() As Integer
Dim totaal() As Integer
dataSize = Abs(tbu_max - tbu_min)
ReDim xPoints(dataSize)
ReDim muur(dataSize)
ReDim vloer(dataSize)
ReDim ramen(dataSize)
ReDim dak(dataSize)
ReDim ventilatie(dataSize)
ReDim totaal(dataSize)
' collect data
dataCounter = 0
For temp = tbu_min To tbu_max
' update values in temperature cell
ws1.Cells.Range("D10").Value = temp
' add x for series
xPoints(dataCounter) = temp
' add data for y series
muur(dataCounter) = ws1.Cells.Range("O24").Value
vloer(dataCounter) = ws1.Cells.Range("O47").Value
ramen(dataCounter) = ws1.Cells.Range("O61").Value
dak(dataCounter) = ws1.Cells.Range("O35").Value
ventilatie(dataCounter) = ws1.Cells.Range("O68").Value
totaal(dataCounter) = ws1.Cells.Range("O74").Value
' next
dataCounter = dataCounter + 1
Next temp
' ask to add total
If MsgBox("Wil je ook het totaal tonen in de grafiek?", vbQuestion + vbYesNo) = vbYes Then
addTotal = True
Else
addTotal = False
End If
If Not ChartExists(ws1, "buitentemperatuur") Then
' Chart does not exist, create chart
With ws1.ChartObjects.Add(Left:=200, Width:=600, Top:=200, Height:=400)
With .chart
.Parent.Name = "buitentemperatuur"
.ChartType = xlXYScatterSmooth
.Axes(xlValue).HasMajorGridlines = False
.Axes(xlCategory).Crosses = xlMinimum
.Axes(xlValue).MinimumScale = 0
.HasLegend = True
.HasTitle = True
.ChartTitle.Text = "Invloed van de buitentemperatuur"
End With
End With
End If
' Chart does exist, remove old series and update chart
ws1.ChartObjects("buitentemperatuur").Activate
For Each s In ActiveChart.SeriesCollection
s.Delete
Next s
With ws1.ChartObjects("buitentemperatuur")
With .chart
.Axes(xlValue).MaximumScaleIsAuto = True
With .SeriesCollection.NewSeries
.Name = "muur"
.XValues = xPoints
.Values = muur
End With
With .SeriesCollection.NewSeries
.Name = "vloer"
.XValues = xPoints
.Values = vloer
End With
With .SeriesCollection.NewSeries
.Name = "ramen"
.XValues = xPoints
.Values = ramen
End With
With .SeriesCollection.NewSeries
.Name = "dak"
.XValues = xPoints
.Values = dak
End With
With .SeriesCollection.NewSeries
.Name = "ventilatie"
.XValues = xPoints
.Values = ventilatie
End With
If addTotal Then
With .SeriesCollection.NewSeries
.Name = "totaal"
.XValues = xPoints
.Values = totaal
End With
End If
End With
End With
End Sub
Function ChartExists(wsTest As Worksheet, strChartName As String) As Boolean
Dim chTest As ChartObject
On Error Resume Next
Set chTest = wsTest.ChartObjects(strChartName)
On Error GoTo 0
If chTest Is Nothing Then
ChartExists = False
Else
ChartExists = True
End If
End Function
I am trying to make a graph using the following VBa code. But I am getting a Run-time error 424 - Object required at the row:
Set rngChtXVal = .Columns(1).Offset(1).Resize(.Rows.Count - 1)
What is going wrong?
Sub MakeGraph()
Dim myChtObj As ChartObject
Dim rngChtData As Variant
Dim rngChtXVal As Variant
Dim iColumn As Long
sel= Sheets("Data").Range(Cells(1, 1), Cells(200, 2))
rngChtData = sel
' define chart's X values
With rngChtData
Set rngChtXVal = .Columns(1).Offset(1).Resize(.Rows.Count - 1)
End With
' add the chart
Set myChtObj = ActiveSheet.ChartObjects.Add(Left:=250, Width:=425, Top:=10, Height:=240)
With myChtObj.Chart
' make an XY chart
.ChartType = xlLine
' remove extra series
Do Until .SeriesCollection.Count = 0
.SeriesCollection(1).Delete
Loop
' add series from selected range, column by column
For iColumn = 2 To rngChtData.Columns.Count
With .SeriesCollection.NewSeries
.Values = rngChtXVal.Offset(, iColumn - 1)
.XValues = rngChtXVal
.Name = rngChtData(1, iColumn)
End With
Next
End With
End Sub
You've named rngChtData and rngChtXVal like Range objects, but you've declared them as Variant. While Variants can be Ranges, it makes debugging your code much harder. Use explicit variable types whenever possible. To resolve your issue, change your code like this:
Sub MakeGraph()
Dim myChtObj As ChartObject
Dim rngChtData As Range
Dim rngChtXVal As Range
Dim iColumn As Long
With Sheets("Data")
Set rngChtData = .Range(.Cells(1, 1), .Cells(200, 2))
End With
' define chart's X values
With rngChtData
Set rngChtXVal = .Columns(1).Offset(1).Resize(.Rows.Count - 1)
End With