Create a graph of a column with gaps between data - excel

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.

Related

How to Automate my Manual Selection Process in VBA

I have a manual selection process that I have tried but failed to automate, so I am reaching out for help. I have attached an image of my Excel sheet as a visual guide when reading my process. Excel Snapshot.
I select cell "L2" and run the code below. It finds the first instance of the value within "A2:J1501" and cuts the whole row. It pastes the row onto the sheet named Lineups. Then it highlights each of the values of the cut row in column "L:L" to let me know that value has been used. I then manually select the next non-highlighted value (in the image example it would be "L2") and run the code again, and again, and again, until every row of L:L is highlighted. This process can take some time depending on the number of rows in L:L so I was hoping I can get some help to automate.
Thank you very much.
Sub ManualSelect()
Dim rng As Range
Set rng = Range("A1:J1501")
Dim ac As Range
Set ac = Application.ActiveCell
rng.Find(what:=ac).Select
Range("A" & ActiveCell.Row).Resize(1, 10).Cut
ActiveWindow.ScrollRow = 1
Sheets("Lineups").Select
nextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(nextRow, 1).Select
ActiveSheet.Paste
Sheets("Data").Select
Dim wsData As Worksheet
Dim wsLineups As Worksheet
Dim rngToSearch As Range
Dim rngLineupSet As Range
Dim rngPlayerID As Range
Dim Column As Long
Dim Row As Long
Dim LastRow As Long
Set wsData = Sheets("Data")
Set wsLineups = Sheets("Lineups")
Set rngPlayerID = wsData.Range("L2:K200")
Set rngToSearch = rngPlayerID
LastRow = wsLineups.Cells(Rows.Count, 1).End(xlUp).Row
For Row = 2 To LastRow
For Column = 1 To 10
Set rngLineupSet = rngPlayerID.Find(what:=wsLineups.Cells(Row, Column), LookIn:=xlValues)
If Not rngLineupSet Is Nothing Then rngLineupSet.Interior.Color = 65535
Next Column
Next Row
End Sub
This should be pretty close:
Sub ManualSelect()
Dim wsData As Worksheet, c As Range, dict As Object, v, rw As Range
Dim wsLineups As Worksheet, c2 As Range, f As Range
Set dict = CreateObject("scripting.dictionary") 'for tracking already-seen values
Set wsLineups = ThisWorkbook.Worksheets("Lineups")
Set wsData = ThisWorkbook.Worksheets("Data")
For Each c In wsData.Range("L2", wsData.Cells(Rows.Count, "L").End(xlUp))
v = c.Value
If dict.exists(CStr(v)) Then
c.Interior.Color = vbYellow 'already seen this value in L or a data row
Else
'search for the value in
Set f = wsData.Range("A2:J1501").Find(v, lookat:=xlWhole, LookIn:=xlValues, searchorder:=xlByRows)
If Not f Is Nothing Then
Set rw = f.EntireRow.Columns("A").Resize(1, 10) 'A to J
For Each c2 In rw.Cells 'add all values from this row to the dictionary
dict(CStr(c2)) = True
Next c2
rw.Cut Destination:=wsLineups.Cells(Rows.Count, "A").End(xlUp).Offset(1)
c.Interior.Color = vbYellow
Else
'will there always be a match?
c.Interior.Color = vbRed 'flag no matching row
End If
End If 'haven't already seen this col L value
Next c 'next Col L value
End Sub
I believe this should do it (updated):
Sub AutoSelect()
Dim wsData As Worksheet, wsLineups As Worksheet
Dim rng As Range, listIDs As Range
Set wsData = ActiveWorkbook.Sheets("Data")
Set wsLineups = ActiveWorkbook.Sheets("Lineups")
Set rng = wsData.Range("A2:J1501")
'get last row col L to define list
LastRowL = wsData.Range("L" & Rows.Count).End(xlUp).Row
Set listIDs = wsData.Range("L2:L" & LastRowL)
'loop through all cells in list
For i = 1 To listIDs.Rows.Count
myCell = listIDs.Cells(i)
'retrieve first mach in listID
checkFirst = Application.Match(myCell, listIDs, 0)
'only check first duplicate in list
If checkFirst = i Then
'get new row for target sheet as well (if sheet empty, starting at two)
newrow = wsLineups.Range("A" & Rows.Count).End(xlUp).Row + 1
'check if it is already processed
Set processedAlready = wsLineups.Cells(2, 1).Resize(newrow - 1, rng.Columns.Count).Find(What:=myCell, lookat:=xlWhole, LookIn:=xlValues)
'if so, color yellow, and skip
If Not processedAlready Is Nothing Then
listIDs.Cells(i).Interior.Color = vbYellow
Else
'get fist match for value, if any (n.b. "xlWhole" ensures whole match)
Set foundMatch = rng.Find(What:=myCell, lookat:=xlWhole, LookIn:=xlValues)
'checking for a match
If Not foundMatch Is Nothing Then
'get the row
foundRow = foundMatch.Row - rng.Cells(1).Row + 1
'specify target range and set it equal to vals from correct row in rng
wsLineups.Cells(newrow, 1).Resize(1, rng.Columns.Count).Value2 = rng.Rows(foundRow).Value
'clear contents rng row
rng.Rows(foundRow).ClearContents
'give a color to cells that actually got a match
listIDs.Cells(i).Interior.Color = vbYellow
Else
'no match
listIDs.Cells(i).Interior.Color = vbRed
End If
End If
Else
'duplicate already handled, give same color as first
listIDs.Cells(i).Interior.Color = listIDs.Cells(checkFirst).Interior.Color
End If
Next i
End Sub
Also, I think, slightly faster than the other solution offered (because of the nested loop there?). Update: I got a bit confused about the nested loop in the answer by Tim Williams, but I missed that you also want to "accept" the values in the list that matched on a row that is already gone. I fixed this in the updated version by checking if a value that fails to match on the data range has already been transferred to Lineups. Provided that doing so is permissible, this method avoids the nested loop.
I checked both methods for speed (n = 50) on a list (n = 200) for the full data range, ended up with average of 1.70x faster... But maybe speed is not such a big deal, if you're coming from manual labor :)

How can I create a chart from unique values in a range

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.

Create multiple charts from dynamic columns in a table

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

Conditional formatting/testing headers against prescribed header list (Excel-VBA)

I use VBA rarely and am always re-learning. This is my first posting.
I am using OCR to pull in tables from PDFs to individual worksheets (usually 100-200 tabs) and I have VBA programming ready to consolidate the data based on header values. But the headers are error prone and need to be reviewed first. I want to run a VBA macro that tests headers in row 1 against a set list and highlight those headers that exactly match.
I found a great start with Conditional formatting over huge range in excel, using VBA (Dictionary Approach) which tests lists, but I am struggling to convert the code to handle rows instead of columns. (Next I plan to have it run on every tab in the workbook, but am stuck at the testing stage).
Here is my current edit of the original code to pull from rows, but I get a subscript out of range on If dict2.Exists(vals(i)) Then
Option Explicit
Sub main3()
Dim mainRng As Range, list1Rng As Range
Dim mainDict As New Scripting.Dictionary, list1Dict As New
Scripting.Dictionary 'Main is Header and list1 is prescribed header list
Set mainRng = GetRange(Worksheets("Main"), "1") '<--| get "Main" sheet row "1" range from column A right to last non empty column
Set list1Rng = GetRange(Worksheets("list1"), "1") '<--| get "list1" sheet row "1" range from column A right to last non empty column
Set mainDict = GetDictionary(mainRng)
Set list1Dict = GetDictionary(list1Rng)
ColorMatchingRange2 list1Rng, list1Dict, mainDict
End Sub
Sub ColorMatchingRange2(rng1 As Range, dict1 As Scripting.Dictionary, dict2 As Scripting.Dictionary)
Dim unionRng As Range
Dim vals As Variant
Dim i As Long
vals = rng1.Value 'oringinal code transposed with = Application.Transpose(rng1.Value)
Set unionRng = rng1.Offset(rng1.Rows.Count).Resize(1, 1)
For i = LBound(vals) To UBound(vals)
If dict2.Exists(vals(i)) Then Set unionRng = Union(unionRng, rng1(1, i))
Next i
Set unionRng = Intersect(unionRng, rng1)
If Not unionRng Is Nothing Then
With unionRng.Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
End With
End If
End Sub
Function GetDictionary(rng As Range) As Scripting.Dictionary
Dim dict As New Scripting.Dictionary
Dim vals As Variant
Dim i As Long
vals = rng.Value 'oringinal code transposed with=Application.Transpose(rng.Value)
On Error Resume Next
For i = LBound(vals) To UBound(vals)
dict.Add vals(i), rng(1, i).Address
Next i
On Error GoTo 0
Set GetDictionary = dict
End Function
Function GetRangeRow(ws As Worksheet, rowIndex As String) As Range
With ws '<--| reference passed worksheet
Set GetRangeRow = .Range("A" & rowIndex, .Cells(1, .Columns.Count).End(xlToLeft)) '<--| set its row "rowIndex" range from row 1 right to last non empty column
End With
End Function
More background, the VBA will be in a Control Workbook with the set header list, and the code will run on the ActiveWorkbook which will be the data across many worksheets, but I believe I've got that figured out.
Simpler approach:
Sub HighlightMatchedHeaders()
Dim rngList As Range, c As Range, v
Dim sht As Worksheet, wb As Workbook
Set wb = ActiveWorkbook 'or whatever
'set the lookup list
With wb.Sheets("list")
Set rngList = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
End With
For Each sht In wb.Worksheets
'ignore the "list" sheet
If sht.Name <> rngList.Worksheet.Name Then
'checking row 1
For Each c In Application.Intersect(sht.Rows(1), sht.UsedRange).Cells
v = Trim(c.Value)
If Len(v) > 0 Then
'has a header: check for match
If Not IsError(Application.Match(v, rngList, 0)) Then
c.Interior.Color = vbRed 'show match
End If
End If
Next c
End If
Next sht
End Sub

Add series to chart

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

Resources