I'm comparing two series and if the value of the 2nd series is less than the 1st at a given XValue, I want to make the bar for that 2nd series red. I tried following some other forum answers and got to this but now I'm stuck...
Public Sub Bar_Colour()
Dim c As Chart
Dim p As Series
Dim a As Series
Dim iPoint As Long
Dim nPoint As Long
Set c = ActiveChart
Set s = ActiveChart.SeriesCollection(1)
Set a = ActiveChart.SeriesCollection(2)
nPoint = s.Points.Count
For iPoint = 1 To nPoint
If a.Points(iPoint).Value < s.Points(iPoint).Value Then
a.Points(iPoint).Interior.Color = RGB(255, 0, 0)
End If
Next iPoint
End Sub
Thanks!
Public Sub Bar_Colour()
Dim c As Chart
Dim p As Series
Dim a As Series
Dim iPoint As Long
Dim nPoint As Long
Set c = ActiveChart
Set s = ActiveChart.SeriesCollection(1)
Set a = ActiveChart.SeriesCollection(2)
nPoint = s.Points.Count
For iPoint = 1 To nPoint
If a.Values(iPoint) < s.Values(iPoint) Then
a.Points(iPoint).Interior.Color = RGB(255, 0, 0)
End If
Next iPoint
End Sub
Related
I am struggling with applying a previous bit of code I have used for the same process in a different workbook.
The process is that I have conditionally formatted a set of information (now on a different sheet) to change colour based on whether either "Lab" or "Office" is selected from the drop down list.
I then wanted (what I believe this code should do however I don't believe I have linked the series correctly) the graph which the information is in relation too to change the relevant data points to that colour, highlighting that on this floor you have selected "Office" or "Lab".
The code I am using starts here:
Sub CellColorsToChart()
Dim xChart As Chart
Dim I As Long, J As Long
Dim xRowsOrCols As Long, xSCount As Long
Dim xRg As Range, xCell As Range
On Error Resume Next
Set xChart = ActiveSheet.ChartObjects("Net Internal Area").Chart.Refresh
If xChart Is Nothing Then Exit Sub
xSCount = xChart.SeriesCollection.Count
For I = 1 To xSCount
J = 1
With xChart.SeriesCollection(I)
Set xRg = ActiveSheet.Range(Split(Split(.Formula, ",")(2), "!")(1))
If xSCount > 4 Then
xRowsOrCols = xRg.Columns.Count
Else
xRowsOrCols = xRg.Rows.Count
End If
For Each xCell In xRg
.Points(J).Format.Fill.ForeColor.RGB = ThisWorkbook.Colors(xCell.DisplayFormat.Interior.ColorIndex)
.Points(J).Format.Line.ForeColor.RGB = ThisWorkbook.Colors(xCell.DisplayFormat.Interior.ColorIndex)
J = J + 1
Next
End With
Next
End Sub
Document can be downloaded here: https://wetransfer.com/downloads/fbdb338026e7c42cc08193536270cdfc20211115102313/07937d
Any help or tips on how to understand and read this better would be amazing.
Best
Jack
Remove Refresh from this line Set xChart = ActiveSheet.ChartObjects("Net Internal Area").Chart.Refresh and refresh chart after If xChart Is Nothing Then Exit Sub
Option Explicit
Sub CellColorsToChart()
Dim xChart As Chart
Dim I As Long, J As Long, ix As Long
Dim xSCount As Long
Dim xRg As Range, xCell As Range
Set xChart = ActiveSheet.ChartObjects("Net Internal Area").Chart
If xChart Is Nothing Then Exit Sub
xChart.Refresh
xSCount = xChart.SeriesCollection.Count
For I = 1 To xSCount
With xChart.SeriesCollection(I)
J = 1
Set xRg = ActiveSheet.Range(Split(Split(.Formula, ",")(2), "!")(1))
For Each xCell In xRg
ix = xCell.DisplayFormat.Interior.ColorIndex
If ix >= 1 Then
.Points(J).Format.Fill.ForeColor.RGB = ThisWorkbook.Colors(ix)
.Points(J).Format.Line.ForeColor.RGB = ThisWorkbook.Colors(ix)
End If
J = J + 1
Next
End With
Next
End Sub
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
I am trying to use the LinEst function to take values from a range of rows of data and input them into a new sheet under some headings. I only want to do this for a particular number of rows (up to row number defined as "c". My VBA skills are very basic.
Sub Button7_Click()
Sheets.Add.Name = "Down Sweep Power Law"
Dim xrng As Range, yrng As Range
Dim i As Long
Dim Rng As Range
Dim l As Long
Dim k As Long
Dim i2 As Long
Dim c As Long
Dim j As Long
Dim drop As Range
Dim drop2 As Range
Dim DownSweep As Chart, UpSweep As Chart, cht As Chart
Dim ws As Worksheet, smallest
Dim dsws As Worksheet
Set ws = Worksheets("Template") '<< use variables for worksheets!
Set dsws = Worksheets("Down Sweep Power Law")
Set Rng = ws.Range(ws.Range("B11"), ws.Range("B11").End(xlDown))
smallest = WorksheetFunction.Small(Rng, 1)
l = Rng.Find(what:=smallest, LookIn:=xlValues, lookat:=xlWhole).Row
k = Rng.Rows.Count
c = l - 10
Set xrng = ws.Range("C11:CP11")
Set yrng = ws.Range("C201:CP201")
Set drop = dsws.Range("A2")
Set x2rng = xrng.Offset(1, 0)
Set y2rng = yrng.Offset(1, 0)
Set drop2 = drop.Offset(1, 0)
dsws.Range("A1").Value = "(n-1) Value"
dsws.Range("B1").Value = "log(k) Value"
dsws.Range("C1").Value = "(n-1) Value"
dsws.Range("D1").Value = "n Value"
dsws.Range("E1").Value = "R Value"
If i < c Then
Set drop = Application.LinEst(Log10(yrng), Log10(xrng), True, False)
i = i + 1
End If
ITERATE:
If i < c Then
Set drop2 = Application.LinEst(Log10(y2rng), Log10(x2rng), True, False)
x2rng = x2rng.Offset(1, 0)
y2rng = y2rng.Offset(1, 0)
drop2 = drop2.Offset(1, 0)
i = i + 1
GoTo ITERATE
End If
End Sub
the code runs but when I go on the created sheet, there is a #NAME error (2029) and no values are present.
Is there a way to fix this?
Any help would be appreciated.
I think you have omitted a step from your plan. LinEst returns an array and you want to assign the values in that array to the range Drop. You can't assign the array directly to the range. Please try this code.
Option Explicit
Sub Button7_Click()
Dim xrng As Range, yrng As Range
Dim Drop As Range
Dim Arr As Variant ' LinEst result array
Dim Rng As Range
Dim R As Long
Dim l As Long
Dim k As Long
Dim i2 As Long
Dim c As Long
Dim j As Long
Dim DownSweep As Chart, UpSweep As Chart, cht As Chart
Dim ws As Worksheet, Smallest As Variant
Dim dsws As Worksheet
Set ws = Worksheets("Template") '<< use variables for worksheets!
Sheets.Add.Name = "Down Sweep Power Law"
Set dsws = Worksheets("Down Sweep Power Law")
Set Rng = ws.Range(ws.Range("B11"), ws.Range("B11").End(xlDown))
Smallest = WorksheetFunction.Small(Rng, 1)
l = Rng.Find(what:=Smallest, LookIn:=xlValues, LookAt:=xlWhole).Row
k = Rng.Rows.Count
c = l - 10
Set xrng = ws.Range("C11:CP11")
Set yrng = ws.Range("C201:CP201")
Set Drop = dsws.Range("C2:CP2").Offset(0, -2)
dsws.Range("A1").Value = "(n-1) Value"
dsws.Range("B1").Value = "log(k) Value"
dsws.Range("C1").Value = "(n-1) Value"
dsws.Range("D1").Value = "n Value"
dsws.Range("E1").Value = "R Value"
Do While R < c
Arr = Application.LinEst(Log10(yrng), Log10(xrng), True, False)
Drop.Value = Arr ' or perhaps: = Application.Transpose(Arr)
Set xrng = xrng.Offset(1, 0)
Set yrng = yrng.Offset(1, 0)
Set Drop = Drop.Offset(1, 0)
R = R + 1
Loop
End Sub
I don't know what kind of array LinEst will return. You may have to transpose the result.
I also tried to improve your management of ranges. However, the code is entirely untried, for lack of data. There may be logical errors in my code as well as typos but the syntax should be sound. It may not take you all the way over the finish line but I hope it will help you in your quest.
I am writing a code to add multiple series to a line graph. I have also put in a counter to make two separate graphs when a minimum value corresponding to a row is met. My VBA skills are very basic and I get a run time 1004 error at the asterisked line:
Dim xrng As Range
Dim yrng As Range
Dim x2rng As Range
Dim y2rng As Range
Dim i As Integer
Dim Rng As Range
Dim l As Integer
Dim k As Integer
Dim i2 As Integer
Worksheets("Template").Activate
Dim lv As String
lv = Worksheets("Template").Range(Worksheets("Template").Range("B11"), Worksheets("Template").Range("B11").End(xlDown)).Find(WorksheetFunction.Small(Worksheets("Template").Range(Worksheets("Template").Range("B11"), Worksheets("Template").Range("B11").End(xlDown)), 1), , , 1).Address
Range(lv).Select
l = ActiveCell.Row
k = Worksheets("Template").Range(Worksheets("Template").Range("B11"), Worksheets("Template").Range("B11").End(xlDown)).Rows.Count
i = 1
i2 = 1
Set xrng = Worksheets("Template").Range("C11:CP11")
Set yrng = Worksheets("Template").Range("C201:CP201")
Set x2rng = xrng.Offset(1, 0)
Set y2rng = xrng.Offset(1, 0)
Dim Chart1 As Chart
Set Chart1 = Charts.Add
With Chart1
Chart1.ChartType = xlXYScatter
Chart1.SeriesCollection.NewSeries
Chart1.SeriesCollection(1).XValues = xrng
Chart1.SeriesCollection(1).Values = yrng
End With
i = i + 1
ITERATE:
If i < l Then
With Chart1
Chart1.SeriesCollection.NewSeries
Chart1.SeriesCollection(i).XValues = x2rng
' pretend the next line is bold
Chart1.SeriesCollection(i).Values = y2rng
x2rng = x2rng.Offset(1, 0)
y2rng = y2rng.Offset(1, 0)
i = i + 1
GoTo ITERATE
End With
End If
If i < k Then
Dim Chart2 As Chart
Set Chart2 = Charts.Add
With Chart2
Chart2.ChartType = xlXYScatter
Chart2.SeriesCollection.NewSeries
Chart2.SeriesCollection(1).XValues = x2rng
Chart2.SeriesCollection(1).Values = y2rng
End With
End If
i2 = i2 + 1
ITERATE2:
If i < k Then
Chart1.SeriesCollection.NewSeries
Chart1.SeriesCollection(i2).XValues = x2rng
Chart1.SeriesCollection(i2).Values = y2rng
x2rng = x2rng.Offset(1, 0)
y2rng = y2rng.Offset(1, 0)
i2 = i2 + 1
GoTo ITERATE2
End If
I am not sure why I am getting this error.
Any help would be appreciated.
Thanks,
Judoo
I tried to get the unique value of each column in the range "RD" and display them in single column. I need to create an object ("scripting.Dictionary") where there are just as many as the number of columns in Range "RD". I tried this code but it resulted in "Run time error 13".
Private Sub CommandButton1_Click()
Range(Me.RefEdit1).Name = "RD"
Range(Me.RefEdit2).Name = "OT"
Dim d As Object, c As Variant, i As Long, s As Long
Dim JK As Long
Dim o As Collection
JK = Range("RD").Columns.Count
Set d = CreateObject("Scripting.Dictionary")
For k = 0 To JK + 1
d.Item(k) = CreateObject("Scripting.Dictionary").Item(k)
c = Range("RD").Columns(k + 1)
If d.Exists(k) Then
d.Item(k) = d.Item(k) + 1 'increment
Else
d.Item(k) = 1 'set as 1st occurence
End If
For i = 1 To UBound(c, 1)
d.Item(k)(c(i, 1)) = 1
Next i
Range("OT").Cells((k * 5) + 2, 2).Resize(d.Item(k).Count) = Application.Transpose(d.Item(k).Keys)
Range("OT").Cells((k * 5) + 2, 2).Resize(d.Item(k).Count).Sort Key1:=Range("OT").Cells((k * 5) + 2, 2).Resize(d.Item(k).Count)
Next k
End Sub
I'm adding some code below to help loop through a list, looking for unique values, and adding them to a new column. In my example, I enclose the entire functionality into a single loop for efficiency. I'm also adding the unique values to a new column in Sheet2 starting with cell A1.
Let me know if you need any additional help.
EDITED CODE BASED ON A MISUNDERSTANDING:
Private Sub CommandButton1_Click()
Dim oDict As Object
Dim rngToScrub As Range
Dim rngNewColumnToStoreUnique As Range
Dim oCol As Range
Dim cel As Range
Set rngToScrub = Range(Me.RefEdit1.Value)
Set rngNewColumnToStoreUnique = Sheet2.Range("A1")
For Each oCol In rngToScrub.Columns
Set oDict = CreateObject("Scripting.Dictionary")
For Each cel In oCol.Cells
If oDict.exists(cel.Value) Then
'Do Nothing for Now
Else
oDict.Add cel.Value, 0
rngNewColumnToStoreUnique.Value = cel.Value
Set rngNewColumnToStoreUnique = rngNewColumnToStoreUnique.Offset(1)
End If
Next cel
Set oDict = Nothing
Next oCol
End Sub
Old code: Misunderstood requirements
Private Sub CommandButton1_Click()
Dim oDict As Object
Dim rngToScrub As Range
Dim rngNewColumnToStoreUnique As Range
Dim cel As Range
Set oDict = CreateObject("Scripting.Dictionary")
Set rngToScrub = Range(Me.RefEdit1.Value)
Set rngNewColumnToStoreUnique = Sheet2.Range("A1")
For Each cel In rngToScrub
If oDict.exists(cel.Value) Then
'Do Nothing for Now
Else
oDict.Add cel.Value, 0
rngNewColumnToStoreUnique.Value = cel.Value
Set rngNewColumnToStoreUnique = rngNewColumnToStoreUnique.Offset(1)
End If
Next cel
End Sub