Code telilng excel not to graph sequential identical numbers

R

RawlinsCross

Active Member
Joined
Sep 9, 2016
Messages
437
Good day,

I have data in two columns - first is just date/time data, second is the variable in question. Normally I just set my ChartData (having declared variables earlier) in the following way. But a lot of the data in column two is sequentially identical. So you might get data in column B such as {43, 46, 41, 41, 41, 41, 56, 34, 64, 45, 45, 45, 23, 41, ......}. How do I set my ChartData to plot only those points that are unique sequentially (note: there can be identical numbers within the set, just not next to each other and note that in the case of the 41, I'd want to plot the 3rd number in the set and of course the 14th number in the set.)


Code: 
Set ChartData = Worksheets("Main Element Profiles").Range("IA7:IA37")
        

ActiveSheet.Range("B2").Select
Set MyChart = ActiveSheet.Shapes.AddChart(xlXYScatterLines).Chart

With MyChart
    .SeriesCollection.NewSeries
    .SeriesCollection(1).Name = ChartName
    .SeriesCollection(1).Values = ChartData
    .SeriesCollection(1).XValues = Worksheets("Main Element Profiles").Range("B7:B37")
    .Legend.Select
        Selection.Delete
    .Axes(xlCategory).Select
        Selection.TickLabels.NumberFormat = "m/d/yyyy"
        Selection.TickLabels.NumberFormat = "[$-409]mmm-dd;@"
    .Axes(xlValue).Select
        Selection.TickLabels.NumberFormat = "#,##0.00"
        Selection.TickLabels.NumberFormat = "#,##0.0%"
    .Axes(xlValue).HasTitle = True
    .Axes(xlValue).AxisTitle.Text = "Extraction (%)"
End With
 

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
Sort by date Sort by votes
You would have to remove sequential duplicates in the XValues range (and their corresponding entry in the values range) before defining your chart ranges. This code may require some editing before it works exactly as you wish:

Code: 
Option Explicit

Sub CreateChartWithoutSequentialDupes()

    Dim ChartData As Range
    Dim ChartXData As Range
    Dim MyChart As Chart
    Dim lDataIndex As Long
    Dim lDataIndex2 As Long

    Dim ChartName As String
    Dim aryX() As Variant
    Dim aryY() As Variant
    Dim aryX2() As Variant
    Dim aryY2() As Variant
    Dim rngcell As Range
    Dim lDataCount As Long
    
    'Define Source Ranges
    Set ChartData = Worksheets("Main Element Profiles").Range("IA7:IA37")
    Set ChartXData = Worksheets("Main Element Profiles").Range("B7:B37")
    
    'Copy data to arrays
    For Each rngcell In ChartData
        lDataIndex = lDataIndex + 1
        ReDim Preserve aryY(1 To lDataIndex)
        aryY(lDataIndex) = rngcell.Value
    Next
    lDataIndex = 0
    For Each rngcell In ChartXData
        lDataIndex = lDataIndex + 1
        ReDim Preserve aryX(1 To lDataIndex)
        aryX(lDataIndex) = rngcell.Value
    Next
    lDataIndex = lDataIndex
    
    'Remove sequential duplicates
    ReDim Preserve aryX2(1 To lDataIndex)
    ReDim Preserve aryY2(1 To lDataIndex)
    
    aryX2(1) = aryX(1)
    aryY2(1) = aryY(1)
    lDataIndex2 = 1
    For lDataIndex = 2 To lDataIndex
        If aryX(lDataIndex) <> aryX(lDataIndex - 1) Then
            lDataIndex2 = lDataIndex2 + 1
            aryX2(lDataIndex2) = aryX(lDataIndex)
            aryY2(lDataIndex2) = aryY(lDataIndex)
        End If
    Next
    ReDim Preserve aryX2(1 To lDataIndex2)
    ReDim Preserve aryY2(1 To lDataIndex2)

    ActiveSheet.Range("B2").Select
    Set MyChart = ActiveSheet.Shapes.AddChart(xlXYScatterLines).Chart
    
    With MyChart
        .SeriesCollection.NewSeries
        .SeriesCollection(1).Name = ChartName
        .SeriesCollection(1).Values = aryY2
        .SeriesCollection(1).XValues = aryX2
        .Legend.Select
            Selection.Delete
        .Axes(xlCategory).Select
            Selection.TickLabels.NumberFormat = "m/d/yyyy"
            Selection.TickLabels.NumberFormat = "[$-409]mmm-dd;@"
        .Axes(xlValue).Select
            Selection.TickLabels.NumberFormat = "#,##0.00"
            Selection.TickLabels.NumberFormat = "#,##0.0%"
        .Axes(xlValue).HasTitle = True
        .Axes(xlValue).AxisTitle.Text = "Extraction (%)"
    End With

End Sub
 
Last edited:
Upvote 0
pbornemeier,

That is freakin' insane - how anyone figures out all this stuff is beyond me. Okay, I'll give it a go and let you know how things turn out. Cheers for the reply.
 
Upvote 0
I have executed the following code, it shows the graph but does not remove identical numbers. What am I missing here?


Code: 
Private Sub UserForm_Initialize()

Dim ChartData As Range
Dim ChartXData As Range
Dim MyChart As Chart
Dim lDataIndex As Long
Dim lDataIndex2 As Long
Dim ChartName As String
Dim aryX() As Variant
Dim aryY() As Variant
Dim aryX2() As Variant
Dim aryY2() As Variant
Dim rngcell As Range
Dim lDataCount As Long

Application.ScreenUpdating = False
Worksheets("Dashboard").Range("H4").Value = ActiveWindow.Zoom
ActiveWindow.Zoom = 85
   
        
'Define Source Ranges
Set ChartData = Worksheets("212-LT").Range("P9:P38")
Set ChartXData = Worksheets("212-LT").Range("B9:B38")
    
'Copy data to arrays
For Each rngcell In ChartData
    lDataIndex = lDataIndex + 1
    ReDim Preserve aryY(1 To lDataIndex)
    aryY(lDataIndex) = rngcell.Value
Next
lDataIndex = 0
For Each rngcell In ChartXData
    lDataIndex = lDataIndex + 1
    ReDim Preserve aryX(1 To lDataIndex)
    aryX(lDataIndex) = rngcell.Value
Next
lDataIndex = lDataIndex
'Remove sequential duplicates
ReDim Preserve aryX2(1 To lDataIndex)
ReDim Preserve aryY2(1 To lDataIndex)
    
aryX2(1) = aryX(1)
aryY2(1) = aryY(1)
lDataIndex2 = 1
For lDataIndex = 2 To lDataIndex
    If aryX(lDataIndex) <> aryX(lDataIndex - 1) Then
        lDataIndex2 = lDataIndex2 + 1
        aryX2(lDataIndex2) = aryX(lDataIndex)
        aryY2(lDataIndex2) = aryY(lDataIndex)
    End If
Next
ReDim Preserve aryX2(1 To lDataIndex2)
ReDim Preserve aryY2(1 To lDataIndex2)
ActiveSheet.Range("B2").Select
Set MyChart = ActiveSheet.Shapes.AddChart(xlXYScatter).Chart

With MyChart
    .SeriesCollection.NewSeries
    .SeriesCollection(1).Name = ChartName
    .SeriesCollection(1).Values = aryY2
    .SeriesCollection(1).XValues = aryX2
    .Legend.Select
        Selection.Delete
    .Axes(xlCategory).Select
        Selection.TickLabels.NumberFormat = "m/d/yyyy"
        Selection.TickLabels.NumberFormat = "[$-409]mmm-dd;@"
    .Axes(xlValue).Select
        Selection.TickLabels.NumberFormat = "#,##0.00"
        Selection.TickLabels.NumberFormat = "#,##0.0"
    .Axes(xlValue).HasTitle = True
    .Axes(xlValue).AxisTitle.Text = "d80 (um)"
End With
   

Dim ImageName As String
ImageName = Application.DefaultFilePath & Application.PathSeparator & "TempChart.jpeg"
MyChart.Export filename:=ImageName
ActiveSheet.ChartObjects(1).Delete
ActiveWindow.Zoom = Worksheets("Dashboard").Range("H4").Value
Application.ScreenUpdating = True
A212D80SMD2.Image1.Picture = LoadPicture(ImageName)
 
End Sub
 
Upvote 0
Revisiting the code and ensuring the source data is as originally stated:

A7:A37 contains Date/Times, which are plotted on the horizontal axis
B7:B37 contains values, which are plotted on the vertical axis, sequential duplicates are not plotted.

Code: 
Option Explicit

Sub CreateChartWithoutSequentialDupes()

    Dim ChartData As Range
    Dim ChartXData As Range
    Dim MyChart As Chart
    Dim lDataIndex As Long
    Dim lDataIndex2 As Long

    Dim ChartName As String
    Dim aryX() As Variant
    Dim aryY() As Variant
    Dim aryX2() As Variant
    Dim aryY2() As Variant
    Dim rngcell As Range
    Dim lDataCount As Long
    
    'Define Source Ranges
    Set ChartXData = Worksheets("Main Element Profiles").Range("A7:A37") 'Contains Date/Time
    Set ChartData = Worksheets("Main Element Profiles").Range("B7:B37")  'Contains Values
    
    'Copy data to arrays
    For Each rngcell In ChartData
        lDataIndex = lDataIndex + 1
        ReDim Preserve aryY(1 To lDataIndex)
        aryY(lDataIndex) = rngcell.Value
    Next
    lDataIndex = 0
    For Each rngcell In ChartXData
        lDataIndex = lDataIndex + 1
        ReDim Preserve aryX(1 To lDataIndex)
        aryX(lDataIndex) = rngcell.Value
    Next
    lDataIndex = lDataIndex
    
    'Remove sequential duplicates
    ReDim Preserve aryX2(1 To lDataIndex)
    ReDim Preserve aryY2(1 To lDataIndex)
    
    aryX2(1) = aryX(1)
    aryY2(1) = aryY(1)
    lDataIndex2 = 1
    For lDataIndex = 2 To lDataIndex
        If aryY(lDataIndex) <> aryY(lDataIndex - 1) Then
            lDataIndex2 = lDataIndex2 + 1
            aryX2(lDataIndex2) = aryX(lDataIndex)
            aryY2(lDataIndex2) = aryY(lDataIndex)
        End If
    Next
    ReDim Preserve aryX2(1 To lDataIndex2)
    ReDim Preserve aryY2(1 To lDataIndex2)

    ActiveSheet.Range("B2").Select
    Set MyChart = ActiveSheet.Shapes.AddChart(xlXYScatterLines).Chart
    
    With MyChart
        .SeriesCollection.NewSeries
        .SeriesCollection(1).Name = ChartName
        .SeriesCollection(1).Values = aryY2
        .SeriesCollection(1).XValues = aryX2
        .Legend.Select
            Selection.Delete
        .Axes(xlCategory).Select
            Selection.TickLabels.NumberFormat = "[$-409]mmm-dd;@"
        .Axes(xlValue).Select
            Selection.TickLabels.NumberFormat = "#,##0.0%"
        .Axes(xlValue).HasTitle = True
        .Axes(xlValue).AxisTitle.Text = "Extraction (%)"
    End With

End Sub
 
Upvote 0
Hi Phil,

Yes, I went through the original code and changed the "IF" statement from aryY <> aryY instead of aryX<>aryX. Reran the code and yes, it does the trick. But there's a complication. The code only works in part (i.e. it removes sequentially identical points) but it doesn't retain the correct value of the date in the x column. What happens is that it reverts the date starting from Jan-00. So basically it's turning the X-axis date values into 1...2...3...4...5....#number of unique non-sequential# values instead of the actual dates.
 
Upvote 0
I did not notice that since I just used sequential days.
I could not get the correct dates using that technique. (Apparently when using a memory range to create a graph there are some limits imposed.)
So, this code copies the non-duplicate data to D7:E7 and below then creates a graph from it:

Code: 
Option Explicit

Sub CreateChartWithoutSequentialDupes()

    Dim ChartData As Range
    Dim ChartXData As Range
    Dim MyChart As Chart
    Dim lDataIndex As Long
    Dim lDataIndex2 As Long

    Dim ChartName As String
    Dim aryX() As Variant
    Dim aryY() As Variant
    Dim aryX2() As Variant
    Dim aryY2() As Variant
    Dim rngcell As Range
    Dim lDataCount As Long
    
    'Define Source Ranges
    Set ChartXData = Worksheets("Main Element Profiles").Range("A7:A37") 'Contains Date/Time
    Set ChartData = Worksheets("Main Element Profiles").Range("B7:B37")  'Contains Values
    
    'Copy data to arrays
    For Each rngcell In ChartData
        lDataIndex = lDataIndex + 1
        ReDim Preserve aryY(1 To lDataIndex)
        aryY(lDataIndex) = rngcell.Value
    Next
    lDataIndex = 0
    For Each rngcell In ChartXData
        lDataIndex = lDataIndex + 1
        ReDim Preserve aryX(1 To lDataIndex)
        aryX(lDataIndex) = rngcell.Value
    Next
    lDataIndex = lDataIndex
    
    'Remove sequential duplicates
    ReDim Preserve aryX2(1 To lDataIndex)
    ReDim Preserve aryY2(1 To lDataIndex)
    
    aryX2(1) = aryX(1)
    aryY2(1) = aryY(1)
    lDataIndex2 = 1
    For lDataIndex = 2 To lDataIndex
        If aryY(lDataIndex) <> aryY(lDataIndex - 1) Then
            lDataIndex2 = lDataIndex2 + 1
            aryX2(lDataIndex2) = aryX(lDataIndex)
            aryY2(lDataIndex2) = aryY(lDataIndex)
        End If
    Next
    ReDim Preserve aryX2(1 To lDataIndex2)
    ReDim Preserve aryY2(1 To lDataIndex2)
    
    'Copy the non-duplicate coordinates to D7:E7 & below
    Range("D7").Resize(lDataIndex2, 1).Value = Application.Transpose(aryX2)
    Range("E7").Resize(lDataIndex2, 1).Value = Application.Transpose(aryY2)

    'Make a graphbased on those coordinates
    ActiveSheet.Range("D7").Select
    Set MyChart = ActiveSheet.Shapes.AddChart(xlLine).Chart
    
    With MyChart
        .SeriesCollection.NewSeries
        .SeriesCollection(1).Name = ChartName
        '.SeriesCollection(1).Values = aryY2
        '.SeriesCollection(1).XValues = aryX2
        .Legend.Select
            Selection.Delete
        .Axes(xlCategory).Select
            Selection.TickLabels.NumberFormat = "[$-409]mmm-dd;@"
        .Axes(xlValue).Select
            Selection.TickLabels.NumberFormat = "#,##0.0%"
        .Axes(xlValue).HasTitle = True
        .Axes(xlValue).AxisTitle.Text = "Extraction (%)"
    End With

End Sub
 
Upvote 0
Yep, that worked. Interesting how the X-dates won't transfer initially. One thing I've noticing. It's necessary to clear the range before copying the non-duplicate data.

Code: 
'Clear any data that may be in the range D116:E145
Range("D116:E145").Clear

'Copy the non-duplicate coordinates to D116:E116 & below
Range("D116").Resize(lDataIndex2, 1).Value = Application.Transpose(aryX2)
Range("E116").Resize(lDataIndex2, 1).Value = Application.Transpose(aryY2)
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Question Question
Proper sizing of graph picture on userform image control
Replies
0
Views
1K
RawlinsCross
R
R
  • Question Question
Passing arguments to a graphing function
8 9 10
Replies
93
Views
8K
RawlinsCross
R
R
  • Question Question
Excel Arrays - Making new ranges by deleting sequential duplicates from old ranges
Replies
0
Views
586
RawlinsCross
R
R
  • Question Question
Userform Chart, adding, deleting series with combobox entries
Replies
0
Views
517
RawlinsCross
R
R
  • Question Question
Legend manipulation
Replies
0
Views
481
RawlinsCross
R

Forum statistics

Threads
1,223,903
Messages
6,175,287
Members
452,631
Latest member
a_potato

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top