Scatter Graph Markers - VBA

[VBAkgb]

Hello All,

Been struggling trying to adapt my working VBA to a user friendly one. I have data in the form:

| X. |. Y. |
A. |. 1. |. 2. |
B. |. 2. |. 3. |
C. |. 3. |. 3. |

With A, B, and C with different conditional formatting colour.

I am developing a scatter graph with automatic labelling for each point and automatic marker colouring for each point using the cell offset to the left of the data.

The labelling code I have works perfectly but I've had difficulty developing my colouring code. It works but I have to select the range each time. If anybody can help me adapt it it would be much appreciated.

Sub AttachLabelsToPoints()

 

   'Dimension variables.

   Dim Counter As Integer, ChartName As String, xVals As String

 

   ' Disable screen updating while the subroutine is run.

   Application.ScreenUpdating = False

 

   'Store the formula for the first series in "xVals".

   xVals = ActiveChart.SeriesCollection(1).Formula

 

   'Extract the range for the data from xVals.

   xVals = Mid(xVals, InStr(InStr(xVals, ","), xVals, _

      Mid(Left(xVals, InStr(xVals, "!") - 1), 9)))

   xVals = Left(xVals, InStr(InStr(xVals, "!"), xVals, ",") - 1)

   Do While Left(xVals, 1) = ","

      xVals = Mid(xVals, 2)

   Loop

 

   'Attach a label to each data point in the chart.

   For Counter = 1 To Range(xVals).Cells.Count

     ActiveChart.SeriesCollection(1).Points(Counter).HasDataLabel = _

         True

      ActiveChart.SeriesCollection(1).Points(Counter).DataLabel.Text = _

         Range(xVals).Cells(Counter, 1).Offset(0, -1).Value

   Next Counter

 

End Sub

 

 

 

 

 

 

 

 

Sub ColorPoints()

 

    Dim cht As Chart

 

    Dim ser As Series

 

    Dim pnt As Point

 

    Dim i As Long, j As Long

 

    Dim rng As Range

 

    Set cht = ActiveChart

 

    Set ser = cht.SeriesCollection(1)

 

    Set rng = ActiveSheet.Range("AH16:AH22") ' Each of these cells has a different color

 

    j = 0

 

    For i = 1 To ser.Points.Count

 

        j = j + 1

 

        Set pnt = ser.Points(i)

 

        pnt.MarkerBackgroundColor = rng(j).DisplayFormat.Interior.Color ' Cycle through available colors

 

        If (j > rng.Count) Then j = 0

 

    Next i

 

End Sub

Cheers. (Apologies for poor formatting, having to complete this on my phone whilst on the move).

 

[VBAkgb]

Hello All,

Been struggling trying to adapt my working VBA to a user friendly one. I have data in the form:

| X. |. Y. |
A. |. 1. |. 2. |
B. |. 2. |. 3. |
C. |. 3. |. 3. |

With A, B, and C with different conditional formatting colour.

I am developing a scatter graph with automatic labelling for each point and automatic marker colouring for each point using the cell offset to the left of the data.

The labelling code I have works perfectly but I've had difficulty developing my colouring code. It works but I have to select the range each time. If anybody can help me adapt it it would be much appreciated.

Sub AttachLabelsToPoints()

 

   'Dimension variables.

   Dim Counter As Integer, ChartName As String, xVals As String

 

   ' Disable screen updating while the subroutine is run.

   Application.ScreenUpdating = False

 

   'Store the formula for the first series in "xVals".

   xVals = ActiveChart.SeriesCollection(1).Formula

 

   'Extract the range for the data from xVals.

   xVals = Mid(xVals, InStr(InStr(xVals, ","), xVals, _

      Mid(Left(xVals, InStr(xVals, "!") - 1), 9)))

   xVals = Left(xVals, InStr(InStr(xVals, "!"), xVals, ",") - 1)

   Do While Left(xVals, 1) = ","

      xVals = Mid(xVals, 2)

   Loop

 

   'Attach a label to each data point in the chart.

   For Counter = 1 To Range(xVals).Cells.Count

     ActiveChart.SeriesCollection(1).Points(Counter).HasDataLabel = _

         True

      ActiveChart.SeriesCollection(1).Points(Counter).DataLabel.Text = _

         Range(xVals).Cells(Counter, 1).Offset(0, -1).Value

   Next Counter

 

End Sub

 

 

 

 

 

 

 

 

Sub ColorPoints()

 

    Dim cht As Chart

 

    Dim ser As Series

 

    Dim pnt As Point

 

    Dim i As Long, j As Long

 

    Dim rng As Range

 

    Set cht = ActiveChart

 

    Set ser = cht.SeriesCollection(1)

 

    Set rng = ActiveSheet.Range("AH16:AH22") ' Each of these cells has a different color

 

    j = 0

 

    For i = 1 To ser.Points.Count

 

        j = j + 1

 

        Set pnt = ser.Points(i)

 

        pnt.MarkerBackgroundColor = rng(j).DisplayFormat.Interior.Color ' Cycle through available colors

 

        If (j > rng.Count) Then j = 0

 

    Next i

 

End Sub

Cheers. (Apologies for poor formatting, having to complete this on my phone whilst on the move).

Now I'm home I'll explain my situation better.

I have data in the form:

[TABLE="width: 192"]
<colgroup><col span="3"></colgroup><tbody>[TR]
[TD][TABLE="width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]x[/TD]
[TD]y[/TD]
[/TR]
[TR]
[TD]a[/TD]
[TD]1[/TD]
[TD]3[/TD]
[/TR]
[TR]
[TD]b[/TD]
[TD]2[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]c[/TD]
[TD]3[/TD]
[TD]1[/TD]
[/TR]
</tbody>[/TABLE]

[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
A, B and C are conditionally formatted with a colour.

I have 2 VBA macros which have helped me digest the data. One labels the scatter markers with data in the first column. The other assigns a colour to the markers based on the conditional formatting - however the labelling macro is much more user friendly and after assigned to the graph automatically reads the data in the far left column, I have to select the range for the colour macro.

I'm trying to adapt the 'colour' macro to be more like the 'labelling' macro however I've had no luck today. I've posted them both below - I've kept the colour macro in its working state.


'Labelling'

Sub AttachLabelsToPoints()


   'Dimension variables.
   Dim Counter As Integer, ChartName As String, xVals As String


   ' Disable screen updating while the subroutine is run.
   Application.ScreenUpdating = False


   'Store the formula for the first series in "xVals".
   xVals = ActiveChart.SeriesCollection(1).Formula


   'Extract the range for the data from xVals.
   xVals = Mid(xVals, InStr(InStr(xVals, ","), xVals, _
      Mid(Left(xVals, InStr(xVals, "!") - 1), 9)))
   xVals = Left(xVals, InStr(InStr(xVals, "!"), xVals, ",") - 1)
   Do While Left(xVals, 1) = ","
      xVals = Mid(xVals, 2)
   Loop


   'Attach a label to each data point in the chart.
   For Counter = 1 To Range(xVals).Cells.Count
     ActiveChart.SeriesCollection(1).Points(Counter).HasDataLabel = _
         True
      ActiveChart.SeriesCollection(1).Points(Counter).DataLabel.Text = _
         Range(xVals).Cells(Counter, 1).Offset(0, -1).Value
   Next Counter


End Sub

'Colour'

Sub ColorPoints()


 


    Dim cht As Chart


 


    Dim ser As Series


 


    Dim pnt As Point


 


    Dim i As Long, j As Long


 


    Dim rng As Range


    Set cht = ActiveChar


    Set ser = cht.SeriesCollection(1)


    Set rng = ActiveSheet.Range("D8:D12") ' Each of these cells has a different color


    j = 0




    For i = 1 To ser.Points.Count


        j = j + 1


        Set pnt = ser.Points(i)


        pnt.MarkerBackgroundColor = rng(j).DisplayFormat.Interior.Color ' Cycle through available colors


        If (j > rng.Count) Then j = 0


    Next i




End Sub

https://imgur.com/a/AWEQBVp

 

[VBAkgb]

Appreciate it. Good way to do it and better than the one I came up with today. I just added multiple series and loops.

One other issue for anyone who can think of a way round my problem. The labelling macro works perfectly however I have a huge data set and sort and filter the points to suit the application. Unfortunately the labelling macro isn't as dynamic and doesn't change with the filtering process. Maybe this simply isn't fixable. Applying the macro after the filter is applied causes an error.

Any help would be much appreciated -final piece of the puzzle hopefully!!

 

[VBAkgb]

To further explain. It labels from the data in the first row in the data series everytime even though it will be hidden and row 3000 may be only one showing.