I have this macro I want to make usable to run it in every chart in the active worksheet
Sub ColorRangeValues()
Dim i As Long
ActiveSheet.ChartObjects(1).Activate
For i = 1 To ActiveChart.SeriesCollection.Count
With ActiveChart.SeriesCollection(i)
Values_Array = .Values
For j = LBound(Values_Array, 1) To UBound(Values_Array, 1)
Select Case Values_Array(j)
Case Is < Range("B7")
.Points(j).Interior.Color = RGB(217, 0, 0)
Case Is > Range("B8")
.Points(j).Interior.Color = RGB(0, 128, 0)
Case Else
.Points(j).Interior.Color = RGB(192, 192, 192)
End Select
Next
End With
Next
End Sub
Tried changing to a for each chartobject argument but I'm messing up everything...
You can do it like this:
Sub ColorRangeValues()
Dim i As Long
Dim oChtObj As ChartObject
For Each oChtObj In ActiveSheet.ChartObjects
With oChtObj.Chart
For i = 1 To .SeriesCollection.Count
With .SeriesCollection(i)
Values_Array = .Values
For j = LBound(Values_Array, 1) To UBound(Values_Array, 1)
Select Case Values_Array(j)
Case Is < Range("B7")
.Points(j).Interior.Color = RGB(217, 0, 0)
Case Is > Range("B8")
.Points(j).Interior.Color = RGB(0, 128, 0)
Case Else
.Points(j).Interior.Color = RGB(192, 192, 192)
End Select
Next
End With
Next
End With
Next
End Sub
Related
I try to set a border to a existing powerpoint table. It runs through fine (and the row and column number is inserted in each cell as test data), but the border just does not appear. What am I doing wrong?
For i = 1 To myPresentation.Slides(w).Shapes(tableName).Table.Rows.Count
For j = 1 To myPresentation.Slides(w).Shapes(tableName).Table.Columns.Count
myPresentation.Slides(w).Shapes(tableName).Table.Cell(i, j).Shape.TextFrame.TextRange.Text = "R:" & i & " C:" & j
With myPresentation.Slides(w).Shapes(tableName).Table.Cell(i, j)
.Borders(ppBorderTop).DashStyle = msoLineSolid
.Borders(ppBorderBottom).DashStyle = msoLineSolid
.Borders(ppBorderLeft).DashStyle = msoLineSolid
.Borders(ppBorderRight).DashStyle = msoLineSolid
.Borders(ppBorderTop).ForeColor.RGB = RGB(255, 110, 0)
.Borders(ppBorderBottom).ForeColor.RGB = RGB(255, 110, 0)
.Borders(ppBorderLeft).ForeColor.RGB = RGB(255, 110, 0)
.Borders(ppBorderRight).ForeColor.RGB = RGB(255, 110, 0)
.Borders(ppBorderBottom).Weight = 1
.Borders(ppBorderTop).Weight = 1
.Borders(ppBorderLeft).Weight = 1
.Borders(ppBorderRight).Weight = 1
.Borders(ppBorderBottom).Visible = msoTrue
.Borders(ppBorderTop).Visible = msoTrue
.Borders(ppBorderLeft).Visible = msoTrue
.Borders(ppBorderRight).Visible = msoTrue
End With
Next j
Next i
Create a single slide presentation and add only two tables on it. Then run this code:
Public Sub TestMe()
Dim myTable As Table
Dim sh As Shape
For Each sh In ActivePresentation.Slides(1).Shapes
Set myTable = sh.Table
myTable.Cell(1, 1).Borders(ppBorderTop).ForeColor.RGB = RGB(255, 110, 0)
Next sh
End Sub
It should work.
From there try to build a bit further.
I have the following dynamic table,
The last column is a validation column that will mark the row for the MPs I am interested in,
This table will feed a graph in another sheet. What I am trying to do is:
Identify the row in which the Identificators are added (such as DT in this example), and use this as the series number for the colors in a graph, in another sheet.
What I am trying to do is
Dim DTrow As Long
Dim ORrow As Long
Dim EErow As Long
Dim OTrow As Long
Set myRange = Worksheets("Financials").Range("M98:M103")
With Worksheets("NatCo Dashboard").ChartObjects("Chart 9")
DTrow = Application.WorksheetFunction.Match("DT", myRange, 0)
ORrow = Application.WorksheetFunction.Match("MP2", myRange, 0)
EErow = Application.WorksheetFunction.Match("MP3", myRange, 0)
OTrow = Application.WorksheetFunction.Match("MP4", myRange, 0)
Select Case Sheets("Financials").Range(myRange)
Case Is = "DT"
Worksheets("NatCo Dashboard").ChartObjects("Chart 9").Chart.SeriesCollection(DTrow).Format.Fill.ForeColor.RGB = RGB(226, 0, 116)
Case Is = "Orange"
Worksheets("NatCo Dashboard").ChartObjects("Chart 9").Chart.SeriesCollection(ORrow).Format.Fill.ForeColor.RGB = RGB(255, 153, 0)
Case Is = "EE"
Worksheets("NatCo Dashboard").ChartObjects("Chart 9").Chart.SeriesCollection(EErow).Format.Fill.ForeColor.RGB = RGB(52, 161, 160)
Case Is = "Other"
Worksheets("NatCo Dashboard").ChartObjects("Chart 9").Chart.SeriesCollection(OTrow).Format.Fill.ForeColor.RGB = RGB(0, 0, 0)
End Select
End With
I couldn't make it work like this, anyone knows what I could be doing wrong?
Thank you!
If one is supposed to match and you are trying to change the colour of the line (and the lines are in plotted in the same order as in the range). You can revert to .Format.Fill if required.
Option Explicit
Sub test()
Dim DTrow As Variant
Dim ORrow As Variant
Dim EErow As Variant
Dim OTrow As Variant
Dim myRange As Range
Set myRange = Worksheets("Financials").Range("M98:M103")
DTrow = Application.Match("DT", myRange, 0)
ORrow = Application.Match("MP2", myRange, 0)
EErow = Application.Match("MP3", myRange, 0)
OTrow = Application.Match("MP4", myRange, 0)
With Worksheets("NatCo Dashboard").ChartObjects("Chart 9").Chart
Select Case True
Case Not IsError(DTrow)
.SeriesCollection(DTrow).Format.Line.ForeColor.RGB = RGB(226, 0, 116)
Case Not IsError(ORrow)
.SeriesCollection(ORrow).Format.Line.ForeColor.RGB = RGB(255, 153, 0)
Case Not IsError(EErow)
.SeriesCollection(EErow).Format.Line.ForeColor.RGB = RGB(52, 161, 160)
Case Not IsError(OTrow)
.SeriesCollection(OTrow).Format.Line.ForeColor.RGB = RGB(0, 0, 0)
End Select
End With
End Sub
If instead you are trying to colour all matching lines (which seems more likely):
Sub test2()
Dim DTrow As Variant
Dim ORrow As Variant
Dim EErow As Variant
Dim OTrow As Variant
Dim myRange As Range
Set myRange = Worksheets("Financials").Range("M98:M103")
DTrow = Application.Match("DT", myRange, 0)
ORrow = Application.Match("MP2", myRange, 0)
EErow = Application.Match("MP3", myRange, 0)
OTrow = Application.Match("MP4", myRange, 0)
With Worksheets("NatCo Dashboard").ChartObjects("Chart 9").Chart
On Error Resume Next
.SeriesCollection(DTrow).Format.Line.ForeColor.RGB = RGB(226, 0, 116)
.SeriesCollection(ORrow).Format.Line.ForeColor.RGB = RGB(255, 153, 0)
.SeriesCollection(EErow).Format.Line.ForeColor.RGB = RGB(52, 161, 160)
.SeriesCollection(OTrow).Format.Line.ForeColor.RGB = RGB(0, 0, 0)
On Error GoTo 0
End With
End Sub
Edit:
If you want to set the colours for the others that don't match to some default then something like the following.
Note:
You can probably tidy this up
I have hardcoded the series for the Else e.g. .SeriesCollection(1)
You would replace RGB(1, 1, 1) with your default for each line
If you know the index anyway then, for example, .SeriesCollection(DTrow) can just be .SeriesCollection(1)
Sub test3()
Dim DTrow As Variant
Dim ORrow As Variant
Dim EErow As Variant
Dim OTrow As Variant
Dim myRange As Range
Set myRange = Worksheets("Financials").Range("M98:M103")
DTrow = Application.Match("DT", myRange, 0)
ORrow = Application.Match("MP2", myRange, 0)
EErow = Application.Match("MP3", myRange, 0)
OTrow = Application.Match("MP4", myRange, 0)
With Worksheets("NatCo Dashboard").ChartObjects("Chart 9").Chart
If Not IsError(DTrow) Then
.SeriesCollection(DTrow).Format.Line.ForeColor.RGB = RGB(226, 0, 116)
Else
.SeriesCollection(1).Format.Line.ForeColor.RGB = RGB(1, 1, 1)
End If
If Not IsError(ORrow) Then
.SeriesCollection(ORrow).Format.Line.ForeColor.RGB = RGB(255, 153, 0)
Else
.SeriesCollection(2).Format.Line.ForeColor.RGB = RGB(1, 1, 1)
End If
If Not IsError(EErow) Then
.SeriesCollection(EErow).Format.Line.ForeColor.RGB = RGB(52, 161, 160)
Else
.SeriesCollection(3).Format.Line.ForeColor.RGB = RGB(1, 1, 1)
End If
If Not IsError(OTrow) Then
.SeriesCollection(OTrow).Format.Line.ForeColor.RGB = RGB(0, 0, 0)
Else
.SeriesCollection(4).Format.Line.ForeColor.RGB = RGB(1, 1, 1)
End If
End With
End Sub
Your Select Case is borked: It'll check the cell at the top of myRange (And, since myRange will already include the Workbook/Worsheet details, you don't need to use Sheets("Financials").Range(myRange), just myRange)
At the very least, you need a For Each <Range Variable> In myRange.Cells to check each row individually. But, if you're going to do that, you don't need the Match bit...
So, let's simplify: You can just use the name to get the collection. (Assuming that you have given your series a proper/dynamic name)
Observe: DTName = Worksheets("Financials").Cells(6, WorksheetFunction.Match("DT",myRange,0)).Value will give us the value from Column F (the 6th column), unless "DT" does not exist in myRange. (But, that's what On Error is for)
Private Sub MuchShorter()
Dim SearchFor() As Variant, SeriesName As String, SeriesColours() As Variant, lTMP As Long
SearchFor = Array("DT", "MP2", "MP3", "MP4")
SeriesColours = Array(RGB(226, 0, 116), RGB(255, 153, 0), RGB(52, 161, 160), RGB(0, 0, 0))
On Error Resume Next 'Skip any series that don't exist
For lTMP = lBound(SearchFor) To uBound(SearchFor) 'Auto-size
SeriesName = ""
SeriesName = Worksheets("Financials").Cells(6, WorksheetFunction.Match(SearchFor(lTMP), myRange, 0)).Value 'Look in Column M for the code, then get name from Column F
If Len(SeriesName) > 0 Then
ThisWorkbook.Worksheets("NatCo Dashboard").ChartObject("Chart 9").Chart.SeriesCollection(SeriesName).Format.Fill.ForeColor.RGB = SeriesColours(lTMP)
End If
Next lTMP
On Error GoTo 0
End Sub
If you need any more tags, just add them to the SearchFor array, and add the colour to the SeriesColours array
I need help coding this VBA for a work project. I have a map with all the shapes (States) named and I have column U2:U52 with the the State abbreviations and column V2:V52 with the data. I need a macro to run through an "If Then" statement to change the colors and Loop through each State (line of data) based on the data entered.
Sub map1()
Dim Rng As Range
Dim ShapeName As String
Dim SHP As Shape
ShapeName = "AL"
Set Rng = ThisWorkbook.Worksheets("Sheet1").Range("V2")
Set SHP = Rng.Parent.Shapes(ShapeName)
If Rng.Value <= 1.6 Then
SHP.Fill.ForeColor.RGB = RGB(255, 0, 0) 'Red
End If
If Rng.Value > 1.6 And Rng.Value < 2.4 Then
SHP.Fill.ForeColor.RGB = RGB(0, 255, 0) 'Green
End If
If Rng.Value >= 2.4 Then
SHP.Fill.ForeColor.RGB = RGB(255, 255, 0) 'yellow
End If
End Sub
The way its written is for just one shape, how do I change it to run all states without coding it 52 times?
Here is a simple loop that should work.
Sub map1()
Dim Rng As Range
Dim ShapeName As String
Dim SHP As Shape
For i = 2 to 52
ShapeName = ThisWorkbook.Worksheets("Sheet1").Range("U" & i).Value
Set Rng = ThisWorkbook.Worksheets("Sheet1").Range("V" & i)
Set SHP = Rng.Parent.Shapes(ShapeName)
If Rng.Value <= 1.6 Then
SHP.Fill.ForeColor.RGB = RGB(255, 0, 0) 'Red
ElseIf Rng.Value > 1.6 And Rng.Value < 2.4 Then
SHP.Fill.ForeColor.RGB = RGB(0, 255, 0) 'Green
ElseIf Rng.Value >= 2.4 Then
SHP.Fill.ForeColor.RGB = RGB(255, 255, 0) 'yellow
End If
Next i
End Sub
I have been working on a macro for the past week to automatically create charts in excel. I have gotten pretty far along with it (thanks in large part to help from this website and its users), but I am stuck on a seemingly insignificant step. For some reason my line with markers graph shows up with discolorations in it. What I mean by this is that the middle fill of the marker is the standard blue that excel defaults to. I think the issue lies with the [ .Visible = msoTrue] line but no matter how I manipulate the code, I cannot make my markers one solid color.
The code is below
Sub DM1R_Graph()
Dim ws As Worksheet
For Each ws In Sheets
ws.Activate
If ws.Name <> "WSNs" Then
Dim sht As Worksheet
Dim xVals As Range, yVals As Range
Dim co As Shape, cht As Chart, s As Series
Set sht = ActiveSheet
Set co = sht.Shapes.AddChart()
Set cht = co.Chart
'remove any existing series
Do While cht.SeriesCollection.Count > 0
cht.SeriesCollection(1).Delete
Loop
cht.ChartType = xlLineMarkers
'get the extent of the XValues...
'below is the first Y axis entry (Oil)
'(change the 2nd offset number to get what you want)
Set xVals = sht.Range(sht.Range("B2"), sht.Cells(Rows.Count, "B").End(xlUp))
Set yVals = xVals.Offset(0, 2)
Set s = cht.SeriesCollection.NewSeries
s.XValues = xVals
s.Values = yVals
With s.Format.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 176, 80)
.Transparency = 0
.Solid
End With
With s.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 176, 80)
.Transparency = 0
End With
'below is the second y axis entry (Gas)
Set xVals = sht.Range(sht.Range("B2"), sht.Cells(Rows.Count, "B").End(xlUp))
Set yVals = xVals.Offset(0, 4)
Set s = cht.SeriesCollection.NewSeries
s.XValues = xVals
s.Values = yVals
With s.Format.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
.Solid
End With
With s.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
End With
'below is the third y axis entry (water)
Set xVals = sht.Range(sht.Range("B2"), sht.Cells(Rows.Count, "B").End(xlUp))
Set yVals = xVals.Offset(0, 5)
Set s = cht.SeriesCollection.NewSeries
s.XValues = xVals
s.Values = yVals
With s.Format.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 176, 240)
.Transparency = 0
.Solid
End With
With s.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 176, 240)
.Transparency = 0
End With
'end Y axis entries
cht.HasLegend = True
'below applies the legend names to be whatever are in parenthesis'
cht.Legend.Select
ActiveChart.SeriesCollection(1).Name = "Oil (BO)"
ActiveChart.SeriesCollection(2).Name = "Gas (MCF)"
ActiveChart.SeriesCollection(3).Name = "Water (BW)"
'below applies the data labels
cht.SeriesCollection(1).Select
cht.SeriesCollection(1).ApplyDataLabels
cht.SeriesCollection(2).Select
cht.SeriesCollection(2).ApplyDataLabels
cht.SeriesCollection(3).Select
cht.SeriesCollection(3).ApplyDataLabels
'below orients the datalabels to either above,below,right,or left
cht.SeriesCollection(1).Select
ActiveChart.SeriesCollection(1).DataLabels.Select
Selection.Position = xlLabelPositionRight
cht.SeriesCollection(2).Select
ActiveChart.SeriesCollection(2).DataLabels.Select
Selection.Position = xlLabelPositionAbove
cht.SeriesCollection(3).Select
ActiveChart.SeriesCollection(3).DataLabels.Select
Selection.Position = xlLabelPositionLeft
'below moves the chart
Dim iChart As Long
Dim lTop As Double
lTop = ActiveSheet.Range("Q10").Top
For iChart = 1 To ActiveSheet.ChartObjects.Count
ActiveSheet.ChartObjects(iChart).Top = lTop
ActiveSheet.ChartObjects(iChart).Left = ActiveSheet.Range("Q1").Left
lTop = lTop + ActiveSheet.ChartObjects(iChart).Height + ActiveSheet.Range("5:7").Height
Next
'below deals with the chart title
cht.SetElement (msoElementChartTitleAboveChart)
With cht.ChartTitle
.Text = sht.Name & Chr(10) & "Oil,Gas, and Water Production Through Well Life "
.Characters.Font.Size = 12
End With
'below adds a filter to one column. You cannot have more than 1 filter per sheet.
Columns("L:L").Select
Selection.AutoFilter
End If
Next ws
End Sub
Below is a picture showing what I mean. You can see it obviously in the red series, but it also appears in the green and blue series as well.
I believe you need to set the MarkerBackgroundColor on the series.
s.MarkerBackgroundColor = RGB(255, 0, 0)
I am using an excel macro to build a table on a power point slide, and it is incredibly slow iterating through cell (about 1-2 second for each cell). Is there a way to make this process go faster? Here is my Code:
Private Function formatTable(shp As PowerPoint.Shape)
Dim i As Byte
Dim j As Byte
Dim k As Byte
Dim tabCol As Byte
With shp.Table
tabCol = .Columns.Count
For i = 1 To .Rows.Count
For j = 1 To tabCol
With .Cell(i, j).Shape
.TextFrame2.TextRange.Font.Bold = msoTrue
Select Case i
Case 1 ' Header Row
.Fill.ForeColor.RGB = RGB(128, 128, 128)
Case 2, 6, 10, 14, 19 'Elements
.Fill.ForeColor.RGB = RGB(192, 192, 192)
Case 23 'Satisfaction
.Fill.ForeColor.RGB = RGB(255, 255, 153)
Case 27, 29, 31 'Future Behaviors
.Fill.ForeColor.RGB = RGB(204, 255, 104)
Case Else
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.TextFrame2.TextRange.Font.Bold = msoFalse
End Select
With .TextFrame2.TextRange.Font
.Name = "Arial"
.Fill.ForeColor.RGB = IIf(i = 1, vbWhite, vbBlack)
.Size = IIf(j <> 1 And i = 1, 7, 8)
End With
.TextFrame.TextRange.ParagraphFormat.Alignment = IIf(j = 1, ppAlignLeft, ppAlignCenter)
End With
With .Cell(i, j)
.Borders(ppBorderBottom).Weight = 1
.Borders(ppBorderTop).Weight = 1
.Borders(ppBorderLeft).Weight = 1
.Borders(ppBorderRight).Weight = 1
End With
Next
Next
End With
End Function
Unfortunately that is the only way that I know of coloring the cells in a table. I.e. via looping. However you can reduce the time drastically :)
Did you notice the Case Else part? That is the majority of the table. So you can actually remove that from the code and color the entire table in one go using the below code
oPPSlide.Shapes(1).Table.Background.Fill.ForeColor.RGB = RGB(255, 255, 255)
and you can remove the Case Else part. So you will have to loop less. In fact, it will drastically reduce the overall time. See this example that I created.
Sub Sample()
Dim oPPApp As New PowerPoint.Application
Dim oPPPrsn As PowerPoint.Presentation
Dim oPPSlide As PowerPoint.Slide
Dim FlName As String
'~~> Change this to the relevant file
FlName = "C:\Users\Siddharth Rout\Documents\MyFile.PPTX"
oPPApp.Visible = True
'~~> Open the relevant powerpoint file
Set oPPPrsn = oPPApp.Presentations.Open(FlName)
'~~> Change this to the relevant slide which has the shape
Set oPPSlide = oPPPrsn.Slides(1)
'~~> Change the background of the table in one go
oPPSlide.Shapes(1).Table.Background.Fill.ForeColor.RGB = RGB(255, 255, 255)
formatTable oPPSlide.Shapes(1)
'
'~~> Rest of the code
'
End Sub
Private Function formatTable(shp As PowerPoint.Shape)
Dim i As Long, j As Long, k As Long, tabCol As Long
With shp.Table
tabCol = .Columns.Count
For i = 1 To .Rows.Count
For j = 1 To tabCol
With .Cell(i, j).Shape
.TextFrame2.TextRange.Font.Bold = msoTrue
Select Case i
Case 1: .Fill.ForeColor.RGB = RGB(128, 128, 128)
Case 2, 6, 10, 14, 19: .Fill.ForeColor.RGB = RGB(192, 192, 192)
Case 23: .Fill.ForeColor.RGB = RGB(255, 255, 153)
Case 27, 29, 31: .Fill.ForeColor.RGB = RGB(204, 255, 104)
' Case Else
' .Fill.ForeColor.RGB = RGB(255, 255, 255)
' .TextFrame2.TextRange.Font.Bold = msoFalse
End Select
With .TextFrame2.TextRange.Font
.Name = "Arial"
.Fill.ForeColor.RGB = IIf(i = 1, vbWhite, vbBlack)
.Size = IIf(j <> 1 And i = 1, 7, 8)
End With
.TextFrame.TextRange.ParagraphFormat.Alignment = IIf(j = 1, 1, 2)
End With
With .Cell(i, j)
.Borders(ppBorderBottom).Weight = 1
.Borders(ppBorderTop).Weight = 1
.Borders(ppBorderLeft).Weight = 1
.Borders(ppBorderRight).Weight = 1
End With
Next
Next
End With
End Function