I use Holebase for work and it would be very useful for me if excel knew how to differentiate the start of a new series since the macro we have so far only displays one series by making a gap between series.
So the macro I'm trying to manipulate was taken from here and has already been adjusted since the previous one suited a purpose slightly different.
What I want is: Everytime I find a new BH on column A plot a distinct series with the values from column C and column D (x and y respectively) till the next BH on column A.
I managed to sort it out. So the macro first deletes all series inside the chart, second everytime time there is a new value / text on column A it displays the data shown on column C (X) and column D (Y).
No I have only one more problem to sort it out. The x range needs to have a minimum date since excel always adopts 1900 by default
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 s As Series
Dim SourceRangeColor As Long
Set sh = ActiveSheet
sh.ChartObjects(1).Activate
'Set chrt = sh.ChartObjects(1)
For Each s In ActiveChart.SeriesCollection
s.Delete
Next s
With sh
' Get reference to all data
Set rAllData = .Range(.[A1], .[A1].End(xlDown)).Resize(, 4)
' Get reference to first cell in data range
rwStart = 2
Set cl = rAllData.Cells(rwStart, 1)
Do While cl <> ""
'Capture the first cell in the source range then trap the color
Set SourceRange = rAllData.Cells(rwStart, 5)
SourceRangeColor = SourceRange.Interior.Color
' 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, 4)
'ActiveChart.SeriesCollection.Add _
'Source:=rChartData
With ActiveChart.SeriesCollection.NewSeries
.ChartType = xlXYScatterLines
.XValues = rChartData.Offset(, 2).Resize(, 1)
.Values = rChartData.Offset(, 3).Resize(, 1)
.Name = rAllData.Cells(rwStart, 1)
.MarkerBackgroundColor = SourceRangeColor
.MarkerForegroundColor = SourceRangeColor
'.Format.Line.ForeColor.RGB = SourceRangeColor (line colour for workbook 2007-2010)
'.Format.Line.BackColor.RGB = SourceRangeColor (line colour for workbook 2007-2010)
'.Format.Fill.ForeColor.RGB = SourceRangeColor (line colour for workbook 2007-2010)
.Interior.Color = SourceRangeColor
.Border.Color = SourceRangeColor
'.Axes(xlCategory, xlPrimary).CategoryType = xlTimeScale
'.Axes(xlCategory, xlPrimary).TickLabels.NumberFormat = "dd-mm-yyyy"
'.Axes(xlCategory, xlPrimary).MinimumScale = Application.Min.Range("C:C")
'.Axes(xlCategory, xlPrimary).MaximumScale = Application.Max.Range("C:C")
' Get next data set
rwStart = rwStart + rwCnt
Set cl = rAllData.Cells(rwStart, 1)
End With
Loop
End With
End Sub
Thanks
enter image description here
Related
The following macro lists all the chart numbers of by worksheet but it order them and this is not how the charts appear in the sheet.
Sub ListChartNames()
Dim Cht As ChartObject
Dim i As Integer
i = 1
For Each Cht In ActiveSheet.ChartObjects
Cells(i, 1) = Cht.Chart.Name
i = i + 1
Next Cht
End Sub
For example, I have a chart in E6:L17 (let's call this one Chart 1) and another in N6:U17 (let's call this one Chart 11).
Then, I move down to two charts in E19:L30 (let's call this one Chart 400) and another in N19:U30 (let's call this one Chart 2).
Then, I move down to two charts in E32:L43 (let's call this one Chart 3) and another in N32:U43 (let's call this one Chart 12)
Then, I move down to only 1 chart in E45:L56 (let's call this one Chart 13)
Then, I back to two charts in E58:L69 and another in N58:U69 (let's call these Chart 15 and Chart 16)
and so on.....
The above charts are all in columns E through U. But then there is another set in columns Y through AO in same patter and again in AS through BI, etc.
I have like 500 charts and I'd like a macro to list them starting in the first set of columns (E through L) but list them from top to bottom, let to right.
So, the results based on the above would be for columns F through U
Chart 1
Chart 11
Chart 400
Chart 2
Chart 3
Chart 12
Chart 13
Chart 15
Chart 16
The macro above lists the charts in a sorted order which is not what I need.
This also doesn't answer the question: Select chart object based on position in sheet (VBA)
Does this give you what you need?
Sub list_charts_in_top_left_to_bottom_right()
Dim ws As Worksheet, outputsh As Worksheet, last_cell As Range, oChartObj As Object
Set ws = ThisWorkbook.Sheets("SheetWithChartsOnIt")
Set outputsh = ThisWorkbook.Sheets("SheetToWriteTo")
outputsh.Range("A:A").ClearContents
outputsh.Range("A1") = "Output:"
If ws.ChartObjects.Count = 0 Then
outputsh.Range("A2") = "No charts found"
Exit Sub
End If
Debug.Print "Charts found: " & ws.ChartObjects.Count
Set last_cell = ws.Range("A1")
'find bounds of range by expanding last_cell with each chart
For Each oChartObj In ws.ChartObjects
With oChartObj
If .TopLeftCell.Row > last_cell.Row Then Set last_cell = ws.Cells(.TopLeftCell.Row, last_cell.Column)
If .TopLeftCell.Column > last_cell.Column Then Set last_cell = ws.Cells(last_cell.Row, .TopLeftCell.Column)
End With
Next
Debug.Print "Bounds of range: $A$1:" & last_cell.Address
Dim area_to_examine As Range
For col = 5 To last_cell.Column Step 21 'start with column 5 (E) and then jump 21 columns at a time
Set area_to_examine = Range(Columns(col), Columns(col + 17))
Debug.Print "Examining: " & area_to_examine.Address
For Each rw In Intersect(area_to_examine, ws.Range("A1", last_cell.Address).Rows)
For Each cl In rw.Cells
For Each oChartObj In ws.ChartObjects
With oChartObj
If .TopLeftCell.Row = cl.Row And .TopLeftCell.Column = cl.Column Then
outputsh.Cells(outputsh.Rows.Count, "A").End(xlUp).Offset(1) = .Name
Debug.Print .Name
End If
End With
Next
Next
Next
Next
End Sub
This is an alternative method. It's still not using a sort algo, but uses a workaround which (does waste a little time but) should be massively quicker than scanning every cell in the sheet:
Sub list_charts_in_top_left_to_bottom_right_v2()
Dim ws As Worksheet, outputsh As Worksheet, chartCount As Long, x As Long, y As Long, maxZ As Long
Set ws = ThisWorkbook.Sheets("SheetWithChartsOnIt")
Set outputsh = ThisWorkbook.Sheets("SheetToWriteTo")
outputsh.Range("A:A").ClearContents
outputsh.Range("A1").Value = "Chart"
chartCount = ws.ChartObjects.Count
ReDim arrChartlist(chartCount, 1)
If chartCount = 0 Then
outputsh.Range("A2") = "No charts found"
Exit Sub
End If
maxZ = 0
For x = 0 To chartCount - 1
With ws.ChartObjects(x + 1)
arrChartlist(x, 0) = .Name
arrChartlist(x, 1) = (((.TopLeftCell.Column - 2) \ 19) * chartCount * chartCount) + (.TopLeftCell.Column * chartCount) + .TopLeftCell.Row
If maxZ < arrChartlist(x, 1) Then maxZ = arrChartlist(x, 1)
End With
Next
For x = 0 To maxZ
For y = 0 To chartCount - 1
If x = arrChartlist(y, 1) Then
outputsh.Cells(outputsh.Rows.Count, "A").End(xlUp).Offset(1).Value = arrChartlist(y, 0)
End If
Next
Next
End Sub
I'm trying to create graphs of every column of data in a worksheet. As of right now it works as long as there are no gaps in the column of data, but I need it to be robust enough that it works if there are gaps in the data. The data is entered in batches with different columns having different lengths due to different measurement requirements. Each of the rows will also have an identifier in the first column indicating what batch of data that row comes from (see attached file). Since the identifier column will be the same length as the longest data column, I compare the last row of that to the bottom row of any given data column to make sure all the data is getting graphed. However right now the it gets stuck in the loop if there's a gap in the data.
Sub GraphAllColumns()
Dim col As Range 'The cell at the top of the data column
Dim bottomRow As Range
Dim bottomData As Range
Set col = ActiveSheet.Range("B7")
Set bottomRow = Range("A7").End(xlDown)
col.Select
If Not IsEmpty(Selection) Then 'If the worksheet is empty, nothing happens
Do
Set bottomData = Selection.End(xlDown)
If bottomRow.Row <= bottomData.Row Then
'Iterate through every column, select all the data in that column
'then call the create graph subroutine
Call CreateGraph
ActiveCell.Offset(0, 1).Select
Else
If IsEmpty(Selection.End(xlDown)) Then
Call CreateGraph
ActiveCell.Offset(0, 1).Select
Else
Range(Selection, Selection.End(xlDown)).Select
End If
End If
Loop Until IsEmpty(Selection)
End If
End Sub
Here's the CreateGraph subroutine as well. I'm happy the way that it works. I know it isn't the best way, but this is my first time using VBA.
Sub CreateGraph()
Dim startCell As Range 'Starting cell (important for column selection)
Dim graphRange As Range
Set startCell = Selection
Set graphRange = Range(startCell, startCell.End(xlDown)) 'Selects all data in column
'Create chart, define chart type and source data
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlLine
ActiveChart.SetSourceData Source:=graphRange
'Change chart location so that all charts on a sheet are stacked in top left corner
With ActiveChart.Parent
.Top = Range("A1")
.Left = Range("A1")
End With
'Change chart title and other attributes
With ActiveChart
.HasTitle = True
.ChartTitle.Text = startCell.Offset(-2, 0).Value
End With
End Sub
I may still be misunderstanding what you want, but this should get you started.
Sub PlotDataById()
Dim dict As Object, id, ws As Worksheet, rngId As Range
Set ws = ActiveSheet 'or whatever
Set dict = IdRanges(ws.Range("B3")) 'get the ranges for each id
For Each id In dict
Set rngId = dict(id).Offset(0, 1) 'first set of data
Debug.Print "Plotting id - " & id & ":" & rngId.Address
Do While Application.CountA(rngId) > 0
'use resize() to pass only the occupied range
CreateGraph rngId.Resize(Application.CountA(rngId)), id
Set rngId = rngId.Offset(0, 1) 'next column over
Loop
Next id
End Sub
'Capture the ranges occupied by each id in a list, starting at `startCell`
' Assumes list is sorted by id
Function IdRanges(startCell As Range) As Object
Dim c As Range, id, currId, cStart As Range, dict As Object
Set dict = CreateObject("scripting.dictionary")
currId = Chr(0) 'some non-value
Set c = startCell
Do While Len(c.Value) > 0
id = c.Value
If id <> currId Then
If Not cStart Is Nothing Then
dict.Add currId, c.Parent.Range(cStart, c.Offset(-1, 0))
End If
Set cStart = c
currId = id
End If
Set c = c.Offset(1, 0)
Loop
dict.Add currId, c.Parent.Range(cStart, c.Offset(-1, 0))
Set IdRanges = dict
End Function
'Create a plot of `rngData` with title `chtTitle`
Sub CreateGraph(rngData As Range, chtTitle)
Dim co As Shape, cht As Chart, ws As Worksheet
Set ws = rngData.Parent
Set co = ws.Shapes.AddChart
With co.Chart
.ChartType = xlLine
.SetSourceData Source:=rngData
.HasTitle = True
.ChartTitle.Text = chtTitle
End With
With co 'all charts on a sheet are stacked in top left corner
.Top = ws.Range("A1").Top
.Left = ws.Range("A1").Left
End With
End Sub
Using Select/ActiveCell is not a very robust way to structure your code, and typically you can avoid almost all uses of that approach.
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
I have a large data table with a number of different measurements and parameters. I am trying to create a number of charts that organize the data series based on the parameters. For example, if I had data like this:
Xval Yval ParA ParB
22 5 10 0.25
27 7 10 0.5
26 6 20 0.25
25 8 20 0.5
I might want to create two charts - one that has a series for each value of ParA, and one that has a series for each value of ParB. What I want to do is be able to define the series data forumlaicly, saying something like (sudocode)
Series1x = Xval, IF(ParA==10)
Series1y = Yval, IF(ParA==10)
Series2x = Xval, IF(ParA==20)
Series2y = Yval, IF(ParA==20)
This way I can continue to sort however I like, and no change to the chart. I know that I can F9 the selected data to convert to raw numbers, but I would like to be able to reuse the series selection on multiple data sets.
Does anyone know if this is even possible in Excel?
Here is something to get you started. You will have to run the macro "UpdateChart" each time you sort/re-sort the data, but this seems to be working for me.
I create some Names in the macro, and then set the series Values & XValues to those ranges, although that would not strictly be necessary.
Sub UpdateChart()
Dim cht As Chart
Dim srs As Series
Dim s1xVals As Range
Dim s1Vals As Range
Dim s1Test As Double
Dim s2Test As Double
Dim nmAddress As String
Dim nm1 As Name
Dim nm2 As Name
Dim parAVals As Range
Set parAVals = GetRange("Define the ParA range?")
Set s1xVals = GetRange("X Values?")
Set s1Vals = GetRange("Y Values?")
s1Test = Application.InputBox("What filter value for ParA?", "Series 1 Filter")
s2Test = Application.InputBox("What filter value for ParA?", "Series 2 Filter")
'Get the address of all cells matching the filter rule for series 1.'
nmAddress = GetAddress(s1xVals, parAVals, s1Test)
'Add the name to the workbook:'
ActiveWorkbook.Names.Add Name:="Srs1_XValues", RefersTo:=Range(nmAddress), Visible:=True
'Repeat for the Y Values'
nmAddress = GetAddress(s1Vals, parAVals, s1Test)
ActiveWorkbook.Names.Add Name:="Srs1_YValues", RefersTo:=Range(nmAddress), Visible:=True
'Repeat for series 2:'
nmAddress = GetAddress(s1xVals, parAVals, s2Test)
ActiveWorkbook.Names.Add Name:="Srs2_XValues", RefersTo:=Range(nmAddress), Visible:=True
nmAddress = GetAddress(s1Vals, parAVals, s2Test)
ActiveWorkbook.Names.Add Name:="Srs2_YValues", RefersTo:=Range(nmAddress), Visible:=True
Set cht = ActiveSheet.ChartObjects(1).Chart '## Modify as needed.'
'remove any existing data in the chart, or modify as needed.'
For Each srs In cht.SeriesCollection
srs.Delete
Next
'Add the first series:'
Set srs = cht.SeriesCollection.NewSeries
srs.XValues = Range("srs1_XValues")
srs.Values = Range("srs1_YValues")
srs.Name = "Series 1 Name" '## modify as needed.'
'Add the second series:'
Set srs = cht.SeriesCollection.NewSeries
srs.XValues = Range("srs2_xValues")
srs.Values = Range("srs2_YValues")
srs.Name = "Series 2 Name" '## modify as needed.'
End Sub
Function GetAddress(srsVals As Range, filterVals As Range, filterCriteria As Double)
Dim cl As Range
Dim c As Long: c = 1
Dim tmpAddress As String
For Each cl In filterVals
If cl.Value = filterCriteria Then
Debug.Print srsVals.Cells(c).Value
'Create a string value of cell address matching criteria'
If tmpAddress = vbNullString Then
tmpAddress = srsVals.Cells(c).Address
Else:
tmpAddress = tmpAddress & "," & srsVals.Cells(c).Address
End If
End If
c = c + 1
Next
GetAddress = tmpAddress
End Function
Private Function GetRange(msg As String) As Range
Set GetRange = Application.InputBox(msg, Type:=8)
End Function
REVISION
The above method fails when returning string longer than 255 characters, not able to assign the address to a Name or to a series.
Here is a modified version that does not use Names, it merely collects the filtered scores in to an array, and uses those values to define the series.
Like the above solution, you would have to run it any time you change the data.
Sub UpdateChartNoNames()
Dim cht As Chart
Dim srs As Series
Dim s1xVals As Range
Dim s1Vals As Range
Dim s1Test As Double
Dim s2Test As Double
Dim parAVals As Range
Set parAVals = GetRange("Define the ParA range?")
Set s1xVals = GetRange("X Values?")
Set s1Vals = GetRange("Y Values?")
'## Alternatively, you could set these ranges without using the inputbox:'
'Set parAvals = Range("C2:C300") '
'Set s1XVals = Range("A2:A300") '
'Set s1Vals = Range("B2:B300") '
s1Test = Application.InputBox("What filter value for ParA?", "Series 1 Filter")
s2Test = Application.InputBox("What filter value for ParA?", "Series 2 Filter")
Set cht = ActiveSheet.ChartObjects(1).Chart '## Modify as needed.'
'remove any existing data in the chart, or modify as needed.'
For Each srs In cht.SeriesCollection
srs.Delete
Next
'Add the first series:'
Set srs = cht.SeriesCollection.NewSeries
srs.XValues = GetValues(s1xVals, parAVals, s1Test)
srs.Values = GetValues(s1Vals, parAVals, s1Test)
srs.Name = "Series 1 Name" '## modify as needed.'
'Add the second series:'
Set srs = cht.SeriesCollection.NewSeries
srs.XValues = GetValues(s1xVals, parAVals, s2Test)
srs.Values = GetValues(s1Vals, parAVals, s2Test)
srs.Name = "Series 2 Name" '## modify as needed.'
End Sub
Function GetValues(srsVals As Range, filterVals As Range, filterCriteria As Double) As Variant
Dim cl As Range
Dim c As Long: c = 0
Dim tmpVar As Variant
ReDim tmpVar(0)
For Each cl In filterVals
If cl.Value = filterCriteria Then
'Debug.Print srsVals.Cells(c).Value'
'Create a string value of cell address matching criteria'
ReDim Preserve tmpVar(c)
tmpVar(c) = srsVals.Cells(c).Value
c = c + 1
End If
Next
GetValues = tmpVar
End Function
Private Function GetRange(msg As String) As Range
Set GetRange = Application.InputBox(msg, Type:=8)
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