I am quite new to writing any VBA code. I have found some previous code to generate this code.
The code generates 48 plots per sheet that contains the data to generate plots. 24 plots from negative data and 24 plots from positive data.
I.e. if there are 10 sheets (this may vary) of data to plot, the code would generate 10 additional sheets with each containing 48plots.
However, I was wondering if instead of generating 10 additional sheets, it will generate 1 additional sheet containing 48 plots that combines the respective data from each data sheet into each respective plot. I will be open to other solutions as well.
The code is found below:
Sub InsertMultipleCharts()
' Apply Macro to all the existing worksheets
Dim ws As Worksheet
For Each ws In Sheets
ws.Activate
' data particulars
Dim wksData As Worksheet
Const xcol1 As Long = 6 ' column F
Const xcol2 As Long = 29 ' column AC
Const Ycol1 As Long = 30 ' column AD
Const row1 As Long = 3 ' First row containing data for plotting
Dim lastR As Long
Dim selectCol As Long
selectCol = Range("A1").End(xlToRight).Select
lastR = ActiveCell.Column
' change last row to the ending cell with data
Dim selectRow As Long
Dim row2 As Long
selectRow = Range("AD1").End(xlDown).Select
row2 = ActiveCell.Row
' Beginning of the positive data set
Dim row3 As Long
Dim row4 As Long
row3 = row2 + 2
' Last row of the positive data set
row4 = Cells(Rows.Count, 5).End(xlUp).Row
' chart dimensions
Const FirstChartLeft As Long = 50
Const FirstChartTop As Long = 50
Const ChartHeight As Long = 360
Const ChartWidth As Long = 240
' working variables for negative data
Dim wksChart As Worksheet
Dim cht As Chart
Dim Xrange As Range
Dim Yrange As Range
Dim xcol As Long
Dim Ycol As Long
' define sheets
Set wksData = ActiveSheet
Set wksChart = Worksheets.Add
' loop X
For xcol = xcol1 To xcol2
' define x values
Set Xrange = Range(wksData.Cells(row1, xcol), wksData.Cells(row2, xcol))
' Y
Ycol = Ycol1
' define y values
Set Yrange = Range(wksData.Cells(row1, Ycol), wksData.Cells(row2, Ycol))
' insert chart
Set cht = wksChart.Shapes.AddChart2(Style:=240, XlChartType:=xlXYScatterLinesNoMarkers, _
Left:=FirstChartLeft + (xcol - xcol1) * ChartWidth, _
Top:=FirstChartTop + (0) * ChartHeight, _
Width:=ChartWidth, Height:=ChartHeight).Chart
' assign data to chart
cht.SetSourceData Source:=Union(Xrange, Yrange)
' chart data series stage
Dim srs As Series
Set srs = cht.SeriesCollection(1)
' change
srs.Name = wksData.Cells(1, 1)
' chart title
cht.HasTitle = True
'change
cht.ChartTitle.Text = wksData.Cells(1, xcol)
With cht.ChartTitle.Font
.Size = 12
.Bold = False
End With
'change axis to 0dp
cht.Axes(xlValue).TickLabels.NumberFormat = "0"
cht.Axes(xlCategory).TickLabels.NumberFormat = "0"
' Depth in reverse order
cht.Axes(xlValue).ReversePlotOrder = True
' Axis Labels
'x Axis label
cht.SetElement msoElementPrimaryCategoryAxisTitleAdjacentToAxis
'change
cht.Axes(xlCategory).AxisTitle.Text = wksData.Cells(2, xcol)
'Y label axis
cht.Axes(xlValue, xlPrimary).HasTitle = True
cht.Axes(xlValue, xlPrimary).AxisTitle.Text = "Depth(m)"
cht.Axes(xlValue, xlPrimary).AxisTitle.Format.TextFrame2.TextRange.Font.Size = 10
' legend
cht.HasLegend = True
cht.Legend.Position = xlLegendPositionBottom
Next
' Repeat above actions for the other plate element
' working variables for positive data
For xcol = xcol1 To xcol2
' define x values
Set Xrange = Range(wksData.Cells(row3, xcol), wksData.Cells(row4, xcol))
' loop Y
Ycol = Ycol1
' define y values
Set Yrange = Range(wksData.Cells(row3, Ycol), wksData.Cells(row4, Ycol))
' insert chart
Set cht = wksChart.Shapes.AddChart2(Style:=240, XlChartType:=xlXYScatterLinesNoMarkers, _
Left:=FirstChartLeft + (xcol - xcol1) * ChartWidth, _
Top:=FirstChartTop + (1.05) * ChartHeight, _
Width:=ChartWidth, Height:=ChartHeight).Chart
' assign data to chart
cht.SetSourceData Source:=Union(Yrange, Xrange)
' chart data series stage
Dim srs1 As Series
Set srs1 = cht.SeriesCollection(1)
srs1.Name = wksData.Cells(1, 1)
' chart title
cht.HasTitle = True
cht.ChartTitle.Text = wksData.Cells(1, xcol)
With cht.ChartTitle.Font
.Size = 12
.Bold = False
End With
' legend
cht.HasLegend = True
cht.Legend.Position = xlLegendPositionBottom
' Depth axis in reverse order
cht.Axes(xlValue).ReversePlotOrder = True
'change axis to 0dp
cht.Axes(xlValue).TickLabels.NumberFormat = "0"
cht.Axes(xlCategory).TickLabels.NumberFormat = "0"
' Axis Labels
cht.SetElement msoElementPrimaryCategoryAxisTitleAdjacentToAxis
cht.Axes(xlCategory).AxisTitle.Text = wksData.Cells(2, xcol)
cht.Axes(xlValue, xlPrimary).HasTitle = True
cht.Axes(xlValue, xlPrimary).AxisTitle.Text = "Depth(m)"
cht.Axes(xlValue, xlPrimary).AxisTitle.Format.TextFrame2.TextRange.Font.Size = 10
Next
ActiveSheet.Move _
After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
Next ws
End Sub
Related
I have the following table:
And a macro that loops through the first section of the table (rows 6-7) in order to create the Pie-Charts on the right. My target now is to loop through all other tables automatically as well. The next one would be in row11 and create a new Pie Chart for that row, then the next table (rows 15-16) and so on. The header of each table is always red. The problem is that the length of the tables vary, meaning for example in the table1 ("Build", A5:K7) there can be 2 rows like here or 50, but each time I need one PieChart for each row.
Currently I have the following working code for Table1 ("Build" A6:K79) to create the 2 PieCharts automatically, but Im unsure how to make one loop for all tables on the sheet.
Dim rownumber As Integer
Dim LabelRange As Range
Dim ValueRange As Range
Dim Chart As ChartObject
Dim LeftIndent As Long
Dim TopIndent As Long
Dim InhaltsRangeString As String
Dim LetzteZeile As Long
'Intialpositionen für Graphen
LeftIndent = 726
TopIndent = 60
rownumber = 6 'Anfang der Buildtabelle in Reihe 6 (Spalte 1)
Set LabelRange = ThisWorkbook.Worksheets("Testplan Überblick").Range("C5, E5, G5, I5")
Set TPsheet = Worksheets("Testplan Überblick")
Set ValueRange = Union(TPsheet.Cells(rownumber, 3), TPsheet.Cells(rownumber, 5), TPsheet.Cells(rownumber, 7), TPsheet.Cells(rownumber, 9))
'Loop through table 1 which always starts at row 6 (unlike the others which have no set starting point cause the ones before can vary in length!)
For rownumber = 6 To LetzteZeileFunktion Step 1 '"LetzteZeileFunktion" gives me the long value of the last row filled in table 1
Set Chart = Sheets("Testplan Überblick").ChartObjects.Add(Left:=180, Width:=270, Top:=7, Height:=210)
With Chart
.Chart.SetSourceData Source:=ValueRange
.Chart.ChartType = xlPie
.Chart.HasTitle = True
.Chart.SetElement (msoElementChartTitleAboveChart)
.Chart.ChartTitle.Text = Sheets("Testplan Überblick").Cells(rownumber, 1).Value
.Chart.FullSeriesCollection(1).XValues = LabelRange
.Left = LeftIndent
.Top = TopIndent
.Name = Sheets("Testplan Überblick").Cells(rownumber, 1).Value
End With
TopIndent = TopIndent + 225
Next rownumber
End Sub
Any ideas on how to loop through all the tables even though they can all differ in length (amount of rows filled with content for charts) would be greatly appreciated!
Cheers
Use the text in one of the headers to identify the start of the data rows and a blank in column A to end. I have used "testfall qty" in column B.
Option Explicit
Sub CreateCharts()
Const DATA = "Testplan Überblick"
Const ROW_START = 5
Const POSN_LEFT = 726
Const POSN_TOP = 60
Const COL = "B"
Const HEADER = "testfall qty"
Dim wb As Workbook, ws As Worksheet
Dim rngLabel As Range, rngValue As Range
Dim iRow As Long, iLastRow As Long, count As Integer
Dim oCht As ChartObject, sColA As String, bflag As Boolean
bflag = False
Set wb = ThisWorkbook
Set ws = wb.Sheets(DATA)
' scan down the sheet
iLastRow = ws.Cells(Rows.count, "A").End(xlUp).Row
For iRow = ROW_START To iLastRow
' look for Testfall Qty as header
sColA = ws.Cells(iRow, 1)
If LCase(ws.Cells(iRow, COL)) = HEADER Then
'set ranges
Set rngLabel = ws.Range("C1, E1, G1, I1").Offset(iRow - 1)
bflag = True
ElseIf Len(sColA) > 0 And bflag Then
' create chart
Set rngValue = ws.Range("C1, E1, G1, I1").Offset(iRow - 1)
Set oCht = ws.ChartObjects.Add(Left:=180, _
Width:=270, Top:=7, Height:=210)
With oCht
.Left = POSN_LEFT
.Top = POSN_TOP + (count * 255)
.Name = sColA
With .Chart
.SetSourceData Source:=rngValue
.SeriesCollection(1).XValues = rngLabel
.ChartType = xlPie
.HasTitle = True
.SetElement msoElementChartTitleAboveChart
.ChartTitle.Text = sColA
End With
End With
count = count + 1
Else
' end of chart data
bflag = False
End If
Next
MsgBox count & " Charts created", vbInformation
End Sub
I would like to create a macro that runs through a series of data in a table and is able to automatically create multiple formatted graphs from it.
Here is what I'm working with (below):
Sub MakeXYGraph()
'https://stackoverflow.com/questions/62285791/dynamically-select-cells-and-input-in-chart
Dim ws As Worksheet
Set ws = Sheet1 'This is the codename of the sheet where the data is
'For the test, deleting all the previous charts
Dim vChartObject As ChartObject
For Each vChartObject In ws.ChartObjects
vChartObject.Delete
Next vChartObject
'rngData is the range where the data are. It is assumed that nothing else is on the sheet than what you displ
Dim rngData As Range
Set rngData = ws.UsedRange.Offset(1).Resize(ws.UsedRange.Rows.Count - 1)
' Get the number of series
Dim iMaxSeries As Integer
iMaxSeries = Application.WorksheetFunction.Max(rngData.Columns(1))
' Is the actual Series, but in the sheet it called Point
Dim iPoint As Integer
'Used for setting the ranges for the series data
Dim lFirstRow As Long, lLastRow As Long, lFirstColumn As Long, lLastColumn As Long
lFirstColumn = rngData(1).Column
lLastColumn = rngData.Columns(rngData.Columns.Count).Column
'Creating the Chart
Dim cht As ChartObject
Set cht = ws.ChartObjects.Add(Left:=250, Width:=500, Top:=50, Height:=300)
With cht.Chart
.ChartType = xlXYScatterLines
'X axis name
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Vertical Displacement"
'Y-axis name
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Vertical Coordinate"
' deleting the unwanted series (Excel tries to find out the data, but no need for it.)
Do Until .SeriesCollection.Count = 0
.SeriesCollection(1).Delete
Loop
End With
For iPoint = 1 To iMaxSeries
'Search for the first occurence of the point
lFirstRow = rngData.Columns(1).Offset(-1).Find(what:=iPoint).Row
'Search for the first occurence of the second point -1 is the last of this point
If iPoint = iMaxSeries Then
lLastRow = rngData.Rows(rngData.Rows.Count).Row - 1
Else
lLastRow = rngData.Columns(1).Find(what:=iPoint + 1).Row - 1
End If
'Add the series
With cht.Chart.SeriesCollection.NewSeries
.XValues = ws.Range(Cells(lFirstRow, lFirstColumn + 1), Cells(lLastRow, lLastColumn - 1))
.Values = ws.Range(Cells(lFirstRow, lFirstColumn + 2), Cells(lLastRow, lLastColumn))
.Name = "Point " & CStr(iPoint)
End With
Next iPoint
End Sub
Which plots the vertical coordinate vs. vertical displacement columns from this table:
To create this graph:
However, as you can see from the image with the table, I have multiple columns, and I would like to like to make graphs for several columns, all with the same format as the vertical coordinate vs. vertical displacement chart above, without interfering with the previous charts created. For example, the second graph that I would like to create is vertical coordinate vs. vertical stress. There is additional data on this worksheet, so one cannot just assume that the rest of the worksheet is blank.
One issue is that as you can see there are four different point numbers (1,2,3,4) and each point number is iterated 9 times. However, these numbers can change (for example there could be 8 Point numbers with three iterations each, and thus the data is dynamic and shouldn't just consider 4 Point No.'s with 9 iterations). And the table data will always be located starting from cell "C8". The current code deals with this.
The reason why the current code doesn't satisfy this is because it assumes that there is no other data on the worksheet where the table is (but there is). I want to be able to add more columns and create more charts (all of them plotted against vertical coordinate column) without affecting the other charts. Please if there is any way to modify the code so then I could create charts for several sets of data on the same worksheet then that would be much appreciated! I'm not sure what the best way to approach this is. Thank you.
https://drive.google.com/file/d/1cuW2eWYwrkNeJ-TmatiC4-PFodflNbSN/view?usp=sharing
Here's one approach:
Sub MakeXYGraph()
Const PLOT_HEIGHT As Long = 200
Const PLOT_WIDTH As Long = 300
Dim ws As Worksheet
Dim cht As ChartObject
Dim rngData As Range, rngHeaders As Range
Dim col As Long, posTop As Long, posLeft As Long
Dim ptRanges As Object, pt, dataRows As Range, i As Long
Set ws = Sheet1 'This is the codename of the sheet where the data is
For i = ws.ChartObjects.Count To 1 Step -1
ws.ChartObjects(i).Delete
Next i
Set rngData = ws.Range("C7").CurrentRegion
Set rngHeaders = rngData.Rows(1) 'the header row
Set rngData = rngData.Offset(1, 0).Resize(rngData.Rows.Count - 1) 'just the data
Set ptRanges = PointRanges(rngData.Columns(1))
posTop = ws.Range("M2").Top
posLeft = ws.Range("M2").Left
For col = 3 To rngData.Columns.Count
'add the chart
Set cht = NewChart(ws, posLeft, PLOT_WIDTH, posTop, PLOT_HEIGHT, rngHeaders.Cells(col).Value)
'loop over the keys of the dictionary containing the point numbers and corresponding ranges
For Each pt In ptRanges
Set dataRows = ptRanges(pt).EntireRow
With cht.Chart.SeriesCollection.NewSeries
.XValues = dataRows.Columns(rngData.Columns(col).Column)
.Values = dataRows.Columns(rngData.Columns(2).Column)
.Name = "Point " & pt
End With
Next pt
posTop = posTop + PLOT_HEIGHT
Next col
End Sub
'Scan the "point No" column and collect unique values and
' corresponding ranges in a Scripting Dictionary object
' assumes data is sorted by point no
Function PointRanges(pointsRange As Range) As Object
Dim dict As Object, c As Range, p, rng As Range
Set dict = CreateObject("scripting.dictionary")
For Each c In pointsRange.Cells
p = c.Value
If Not dict.exists(p) Then
dict.Add p, c 'add the start cell
Else
Set dict(p) = dict(p).Resize(dict(p).Count + 1) 'resize to add this cell
End If
Next c
Set PointRanges = dict
End Function
'add a chart and do some initial configuration
Function NewChart(ws As Worksheet, L, W, T, H, yAxisName As String)
Dim cht As ChartObject
Set cht = ws.ChartObjects.Add(Left:=L, Width:=W, Top:=T, Height:=H)
With cht.Chart
.ChartType = xlXYScatterLines
.Axes(xlCategory, xlPrimary).HasTitle = True 'X axis name
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = yAxisName
.Axes(xlValue, xlPrimary).HasTitle = True 'Y-axis name
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Vertical Coordinate"
.Axes(xlValue, xlPrimary).ReversePlotOrder = True
Do While .SeriesCollection.Count > 0
.SeriesCollection(1).Delete
Loop
End With
Set NewChart = cht
End Function
Currently, all my charts are cramped together in the same spot in the same worksheet after running my code. So to view them i have to manually drag and move them to another spot. So is there a way such that i can place all the charts in a orderly manner as shown in expected output? If it is really impossible to do something like this, i am ok with offsetting the graph for every 20 cells even though it is abit inconvenient for viewing but still i attempted to do it but fail to make it happen when i include code with current output with the offsetting code.
Current output(looks like there is 1 chart but all the charts are in the same spot)
Below is the code for my current output
Sub plotgraphs()
'Call meangraph
Call sigmagraph
End Sub
Private Sub sigmagraph()
Dim i As Long, c As Long
Dim shp As Shape
Dim Cht As chart, co As Shape
Dim rngDB As Range, rngX As Range, rngY As Range
Dim Srs As Series
Dim ws As Worksheet
Set ws = Sheets("Data")
Set rngDB = ws.Range("A1").CurrentRegion
Set rngX = rngDB.Columns(1)
Set rngY = rngDB.Columns(4)
Do While Application.CountA(rngY) > 0
Set co = Worksheets("meangraphs").Shapes.AddChart
Set Cht = co.chart
With Cht
.ChartType = xlXYScatter
'remove any data which might have been
' picked up when adding the chart
Do While .SeriesCollection.Count > 0
.SeriesCollection(1).Delete
Loop
'add the data
With .SeriesCollection.NewSeries()
.XValues = rngX.Value
.Values = rngY.Value
End With
'formatting...
With Cht.Axes(xlValue)
.MinimumScale = 0
.MaximumScale = 0.5
.TickLabels.NumberFormat = "0.00E+00"
End With
Cht.Axes(xlCategory, xlPrimary).HasTitle = True
Cht.Axes(xlValue, xlPrimary).HasTitle = True
End With
Set rngY = rngY.Offset(0, 2) 'next y values
Loop
Code for offsetting chart for every 20 cells (fail to make it happen)
Dim OutSht As Worksheet
'
Dim PlaceInRange As Range
Set OutSht = ActiveWorkbook.Sheets("sigmagraphs") '<~~ Output sheet
Set PlaceInRange = OutSht.Range("B2:J21") '<~~ Output location
'
' To place charts at a distance between them
For Each chart In Sheets("sigmagraphs").ChartObjects
' OutSht.Paste PlaceInRange
' Code below changes the range itself to something 20 rows below
Set PlaceInRange = PlaceInRange.Offset(20, 0)
Next chart
Expected output
What you are looking for is the .Left and .Top properties of the Shape containing the Chart.
For example, a macro that would setup your charts into a 2-column grid would look like this:
Sub SetupChartsIntoGrid()
Const TopAnchor As Long = 50
Const LeftAnchor As Long = 50
Const HorizontalSpacing As Long = 10
Const VerticalSpacing As Long = 10
Const ChartHeight As Long = 211
Const ChartWidth As Long = 360
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
If shp.Type = msoChart Then
Dim Counter As Long
Counter = Counter + 1
With shp
.Top = TopAnchor + (WorksheetFunction.RoundUp(Counter / 2, 0) - 1) * (VerticalSpacing + ChartHeight)
.Left = LeftAnchor + ((Counter + 1) Mod 2) * (HorizontalSpacing + ChartWidth)
End With
End If
Next
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 have a macro that charts data for me. Everything about the macro works with 1 exception: I want to redesignate the x-axis labels. The macro does do this but it doesn't do it right. In some cases it frame shifts the categories, in others it labels a category completely wrong. The macro is supposed to chart the data by product ID (one chart per product ID) and then change the x-axis category to the label in column F on "Chart Data."
Thanks, in advance, for your help.
Below is the part of the macro that creates the charts and subsequently changes the x axis:
Sub MakeCharts()
Dim sh As Worksheet
Dim rAllData As Range
Dim rChartData As Range
Dim cl As Range
Dim rwStart As Long, rwCnt As Long
Dim chrt As Chart
Set sh = ActiveSheet
ActiveSheet.Range("a1").Select
With sh
' Get reference to all data
Set rAllData = .Range(.[A2], .[A2].End(xlDown)).Resize(, 5)
' Get reference to first cell in data range
rwStart = 1
Set cl = rAllData.Cells(rwStart, 1)
Do While cl <> ""
' cl points to first cell in a station data set
' Count rows in current data set
rwCnt = Application.WorksheetFunction. _
CountIfs(rAllData.Columns(1), cl.Value)
' Get reference to current data set range
Set rChartData = rAllData.Cells(rwStart, 1).Resize(rwCnt, 5)
' Create Chart next to data set
Set chrt = .Shapes.AddChart(xlLineMarkers, _
rChartData.Width, .Range(.[A2], cl).Height).Chart
With chrt
.SetSourceData Source:=rChartData.Offset(0, 1).Resize(, 4)
' -----> Set any chart properties here <-----
' Add Title
.SetElement msoElementChartTitleCenteredOverlay
.ChartTitle.Caption = cl.Value
'Change chart name
.Parent.Name = cl.Value
'Remove Legend
.SetElement (msoElementLegendNone)
' Adjust plot size to allow for title
.PlotArea.Height = .PlotArea.Height - .ChartTitle.Height
.PlotArea.Top = .PlotArea.Top + .ChartTitle.Height
'Change the x-axis to a more organized set
.SeriesCollection(1).XValues = "='Chart Data'!$F$2:$F$1048576"
'Set Max and Min for charts
.Axes(xlValue).MinimumScale = Sheets("Chart Data").Range("K1")
.Axes(xlValue).MaximumScale = Sheets("Chart Data").Range("K2")
'Adjust x-axis to tilt 45 degrees top left to bottom right
.Axes(xlCategory).TickLabels.Orientation = 45
End With
' Get next data set
rwStart = rwStart + rwCnt
Set cl = rAllData.Cells(rwStart, 1)
Loop
End With
under 'Change the x-axis to a more organized set, I used the following code:
.SeriesCollection(1).XValues = "='Chart Data'!" & rChartData.Offset(, 5).Resize(, 1).Address