I was given a macro by a predecessor.
I would like to add automatic colouring of the font (white on dark colours, black on light colours).
I have no experience with visual basic.
Sub colourProgress()
Dim c As Word.Cell
If Selection.Information(wdWithInTable) Then
For Each c In Selection.Tables(1).Range.Cells
If IsNumeric(Left(c.Range.Text, Len(c.Range.Text) - 1)) Then
If Val(c.Range.Text) = 3 Then
c.Shading.BackgroundPatternColor = wdColorYellow
ElseIf Val(c.Range.Text) = 4 Then
c.Shading.BackgroundPatternColor = wdColorOrange
End If
ElseIf InStr(LCase(c.Range.Text), "good") > 0 Then
c.Shading.BackgroundPatternColor = RGB(0, 176, 80)
ElseIf InStr(LCase(c.Range.Text), "exceptional") > 0 Then
c.Shading.BackgroundPatternColor = RGB(148, 55, 257)
ElseIf InStr(LCase(c.Range.Text), "satisfactory") > 0 Then
c.Shading.BackgroundPatternColor = wdColorYellow
ElseIf InStr(LCase(c.Range.Text), "serious") > 0 Then
c.Shading.BackgroundPatternColor = wdColorRed
ElseIf InStr(LCase(c.Range.Text), "concern") > 0 Then
c.Shading.BackgroundPatternColor = RGB(255, 192, 0)
ElseIf InStr(LCase(c.Range.Text), "three or more sub-levels above target") > 0 Then
c.Shading.BackgroundPatternColor = RGB(148, 55, 257)
ElseIf InStr(LCase(c.Range.Text), "two sub-levels above target") > 0 Then
c.Shading.BackgroundPatternColor = wdColorBrightGreen
ElseIf InStr(LCase(c.Range.Text), "one sub-level above target") > 0 Then
c.Shading.BackgroundPatternColor = RGB(0, 176, 80)
ElseIf InStr(LCase(c.Range.Text), "on target") > 0 Then
c.Shading.BackgroundPatternColor = wdColorYellow
ElseIf InStr(LCase(c.Range.Text), "one sub-level below target") > 0 Then
c.Shading.BackgroundPatternColor = RGB(255, 192, 0)
ElseIf InStr(LCase(c.Range.Text), "two or more sub-levels below target") > 0 Then
c.Shading.BackgroundPatternColor = wdColorRed
ElseIf c.RowIndex > 1 Then ' set non-numeric in row 2 and down to White
c.Shading.BackgroundPatternColor = wdColorWhite
End If
Next c
End If
End Sub
I tried adding
c.Font.Color = white
When you type an object name followed by a period in the VBA editor IntelliSense will show you a list of valid options to follow the period:
Font would not have been in that list. However, you can see from the code you already have that an object called Range has a text property. If Range has text, you can logically conclude that it must also have a Font property.
To set the font colour to automatic you would need something like:
c.Range.Font.ColorIndex = wdAuto
However, rather than set the text color for individual cells you would be better to set the color for the entire table. If your document is formatted correctly there should be no need to use code to change the font color, otherwise it can be done with code like this:
Selection.Tables(1).Range.Font.ColorIndex = wdAuto
Thanks for the help everyone. I think this works now.
Sub colourProgress()
Dim c As Word.Cell
If Selection.Information(wdWithInTable) Then
For Each c In Selection.Tables(1).Range.Cells
If InStr(LCase(c.Range.Text), "good") > 0 Then
c.Shading.BackgroundPatternColor = RGB(0, 176, 80)
c.Range.Font.Color = WdColorBlack
ElseIf InStr(LCase(c.Range.Text), "exceptional") > 0 Then
c.Shading.BackgroundPatternColor = RGB(148, 55, 257)
c.Range.Font.Color = WdColorBlack
ElseIf InStr(LCase(c.Range.Text), "satisfactory") > 0 Then
c.Shading.BackgroundPatternColor = wdColorYellow
c.Range.Font.Color = WdColorBlack
ElseIf InStr(LCase(c.Range.Text), "serious") > 0 Then
c.Shading.BackgroundPatternColor = wdColorRed
c.Range.Font.Color = WdColorBlack
ElseIf InStr(LCase(c.Range.Text), "concern") > 0 Then
c.Shading.BackgroundPatternColor = RGB(255, 192, 0)
c.Range.Font.Color = WdColorBlack
ElseIf InStr(LCase(c.Range.Text), "three or more sub-levels above target") > 0 Then
c.Shading.BackgroundPatternColor = RGB(148, 55, 257)
c.Range.Font.Color = WdColorBlack
ElseIf InStr(LCase(c.Range.Text), "two sub-levels above target") > 0 Then
c.Shading.BackgroundPatternColor = wdColorBrightGreen
c.Range.Font.Color = WdColorBlack
ElseIf InStr(LCase(c.Range.Text), "one sub-level above target") > 0 Then
c.Shading.BackgroundPatternColor = RGB(0, 176, 80)
c.Range.Font.Color = WdColorBlack
ElseIf InStr(LCase(c.Range.Text), "on target") > 0 Then
c.Shading.BackgroundPatternColor = wdColorYellow
c.Range.Font.Color = WdColorBlack
ElseIf InStr(LCase(c.Range.Text), "one sub-level below target") > 0 Then
c.Shading.BackgroundPatternColor = RGB(255, 192, 0)
c.Range.Font.Color = WdColorBlack
ElseIf InStr(LCase(c.Range.Text), "two or more sub-levels below target") > 0 Then
c.Shading.BackgroundPatternColor = wdColorRed
c.Range.Font.Color = WdColorBlack
ElseIf Len(c.Range.Text) < 3 Then
c.Shading.BackgroundPatternColor = wdColorGray25
ElseIf c.RowIndex > 1 Then ' set non-numeric in row 2 and down to White
c.Shading.BackgroundPatternColor = wdColorWhite
c.Range.Font.Color = WdColorBlack
End If
Next c
End If
End Sub
For example, provided the strings in your code are all that's in the cells:
Sub ColourProgress()
Application.ScreenUpdating = False
Dim c As Word.Cell, BckClr As Long, FntClr As Long
With Selection
If .Information(wdWithInTable) Then
For Each c In .Tables(1).Range.Cells
Select Case Split(c.Range.Text, vbCr)(0)
Case 3: BckClr = wdColorYellow: FntClr = wdColorAutomatic
Case 4: BckClr = wdColorOrange: FntClr = wdColorAutomatic
Case "good": BckClr = RGB(0, 176, 80): FntClr = wdColorWhite
Case "exceptional": BckClr = RGB(148, 55, 257): FntClr = wdColorWhite
Case "satisfactory": BckClr = wdColorYellow: FntClr = wdColorAutomatic
Case "serious": BckClr = wdColorRed: FntClr = wdColorWhite
Case "concern": BckClr = RGB(255, 192, 0): FntClr = wdColorAutomatic
Case "three or more sub-levels above target": BckClr = RGB(148, 55, 257): FntClr = wdColorWhite
Case "two sub-levels above target": BckClr = wdColorBrightGreen: FntClr = wdColorAutomatic
Case "one sub-level above target": BckClr = RGB(0, 176, 80): FntClr = wdColorWhite
Case "on target": BckClr = wdColorYellow: FntClr = wdColorAutomatic
Case "one sub-level below target": BckClr = RGB(255, 192, 0): FntClr = wdColorAutomatic
Case "two or more sub-levels below target": BckClr = wdColorRed: FntClr = wdColorWhite
Case Else: BckClr = wdColorAutomatic: FntClr = wdColorAutomatic
End Select
c.Shading.BackgroundPatternColor = BckClr
c.Range.Font.Color = FntClr
Next c
End If
End With
Application.ScreenUpdating = True
End Sub
The code I posted before works just fine if the strings in your code are all that's in the cells.
A better and more robust approach than changing the font on just the cells currently containing the darker shading would be:
Sub ColourProgress()
Application.ScreenUpdating = False
Dim c As Word.Cell, BckClr As Long, FntClr As Long
With Selection
If .Information(wdWithInTable) Then
For Each c In .Tables(1).Range.Cells
BckClr = wdColorAutomatic: FntClr = wdColorAutomatic
With c.Range
If Split(.Text, vbCr)(0) = 3 Then BckClr = wdColorYellow: FntClr = wdColorAutomatic
If Split(.Text, vbCr)(0) = 4 Then BckClr = wdColorOrange: FntClr = wdColorAutomatic
If InStr(.Text, "good") > 0 Then BckClr = RGB(0, 176, 80): FntClr = wdColorWhite
If InStr(.Text, "exceptional") > 0 Then BckClr = RGB(148, 55, 257): FntClr = wdColorWhite
If InStr(.Text, "satisfactory") > 0 Then BckClr = wdColorYellow: FntClr = wdColorAutomatic
If InStr(.Text, "serious") > 0 Then BckClr = wdColorRed: FntClr = wdColorWhite
If InStr(.Text, "concern") > 0 Then BckClr = RGB(255, 192, 0): FntClr = wdColorAutomatic
If InStr(.Text, "three or more sub-levels above target") > 0 Then BckClr = RGB(148, 55, 257): FntClr = wdColorWhite
If InStr(.Text, "two sub-levels above target") > 0 Then BckClr = wdColorBrightGreen: FntClr = wdColorAutomatic
If InStr(.Text, "one sub-level above target") > 0 Then BckClr = RGB(0, 176, 80): ntClr = wdColorWhite
If InStr(.Text, "on target") > 0 Then BckClr = wdColorYellow: FntClr = wdColorAutomatic
If InStr(.Text, "one sub-level below target") > 0 Then BckClr = RGB(255, 192, 0): FntClr = wdColorAutomatic
If InStr(.Text, "two or more sub-levels below target") > 0 Then BckClr = wdColorRed: FntClr = wdColorWhite
End With
c.Shading.BackgroundPatternColor = BckClr
c.Range.Font.Color = FntClr
Next c
End If
End With
Application.ScreenUpdating = True
End Sub
This ensures both the shading and the font are updated if the cell contents change.
Related
I'm trying to format the selected table with a colorless first row with a bottom border, interlined light grey rows, and the last row with top and bottom borders.
Everything seems to be working fine except with the last row's top and bottom borders not being styled correctly.
Can you help me fix the problem?
Thanks in advance!
Here's the code:
Sub FormatShape()
Dim oSlide As slide
Dim oShape As Shape
Dim oTable As Table
Dim oCell As cell
Dim iRow As Long
Dim iCol As Long
Set oSlide = Application.ActiveWindow.View.slide
Set oShape = ActiveWindow.Selection.ShapeRange(1)
RowTotal = True
If Not oShape.HasTable Then
MsgBox "Please select a table and try again."
Else
Set oTable = oShape.Table
For iRow = 1 To oTable.Rows.Count
For iCol = 1 To oTable.Columns.Count
With oTable.cell(iRow, iCol)
With .Shape.TextFrame.textRange
.Font.Name = "Graphik LCG"
.Font.size = 10
.Font.Color.RGB = vbBlack
.Font.Bold = True
End With
If iRow = 1 Then
With oTable.cell(iRow, iCol)
.Shape.Fill.ForeColor.RGB = vbWhite
With .Borders(ppBorderTop)
.ForeColor.RGB = vbWhite
.Visible = False
.Weight = 1
.Transparency = 1
End With
With .Borders(ppBorderLeft)
.ForeColor.RGB = vbWhite
.Visible = False
.Weight = 1
.Transparency = 1
End With
With .Borders(ppBorderBottom)
.Visible = True
.ForeColor.RGB = vblack
.Weight = 1
End With
With .Borders(ppBorderRight)
.Visible = False
.ForeColor.RGB = vbBlack
.Weight = 1
.Transparency = 1
End With
End With
Else
.Shape.TextFrame.textRange.Font.Bold = False
' check if odd number
If Not iRow Mod 2 <> 0 Then
.Shape.Fill.ForeColor.RGB = RGB(235, 235, 235)
Else
.Shape.Fill.ForeColor.RGB = vbWhite
End If
With oTable.cell(iRow, iCol)
With .Borders(ppBorderLeft) 'Left
.Visible = msoFalse
.ForeColor.RGB = vbWhite
.Weight = 1
.Transparency = 1
End With
With .Borders(ppBorderBottom) 'Bottom
.Visible = msoTrue
.ForeColor.RGB = vbWhite
.Weight = 1
.Transparency = 1
End With
With .Borders(ppBorderRight) 'Right
.Visible = msoFalse
.ForeColor.RGB = vbWhite
.Weight = 1
.Transparency = 1
End With
If iRow = oTable.Rows.Count - 1 Then
With .Borders(ppBorderBottom)
.Visible = True
.ForeColor.RGB = vblack
.Weight = 1
End With
End If
If iRow = oTable.Rows.Count Then
MsgBox "here"
With .Borders(ppBorderTop)
.Visible = True
.ForeColor.RGB = vblack
.Weight = 1
End With
With .Borders(ppBorderBottom)
.Visible = True
.ForeColor.RGB = vblack
.Weight = 1
End With
oTable.cell(iRow, iCol).Shape.TextFrame.textRange.Font.Bold = True
End If
End With
End If
End With
Next
Next
End If
End Sub
The best way to do this is to edit the presentation XML to create a custom table style. Then you would have a table where you could use the program interface to switch the header and total rows and the banding on and off, just like a real PowerPoint table.
Editing XML is very similar to editing HTML. Here are my articles on how to do this: OOXML Hacking: Custom Table Styles OOXML Hacking: Table Styles Complete OOXML Hacking: Default Table Text
But since you got started on doing this with VBA, let's finish the task. Your code had a bunch of mistakes, but the main issue with tables is that the top border of the bottom row doesn't just belong to the bottom row. It's also the bottom border of the row second from the bottom.
This code sets both the bottom border of the second last row, and the top border of the last row. It's working here:
Sub FormatTable()
Dim oShape As Shape
Dim oTable As Table
Dim oCell As Cell
Dim iRow As Long
Dim iCol As Long
Set oShape = ActiveWindow.Selection.ShapeRange(1)
RowTotal = True
If Not oShape.HasTable Then
MsgBox "Please select a table and try again."
Else
Set oTable = oShape.Table
For iRow = 1 To oTable.Rows.Count
For iCol = 1 To oTable.Columns.Count
With oTable.Cell(iRow, iCol)
With .Shape.TextFrame.TextRange
.Font.Name = "Graphik LCG"
.Font.Size = 10
.Font.Color.RGB = RGB(0, 0, 0)
.Font.Bold = True
End With
If iRow = 1 Then
'Format first row
With oTable.Cell(iRow, iCol)
.Shape.Fill.ForeColor.RGB = RGB(255, 255, 255)
With .Borders(ppBorderTop)
.ForeColor.RGB = RGB(255, 255, 255)
.Visible = False
.Weight = 1
.Transparency = 1
End With
With .Borders(ppBorderLeft)
.ForeColor.RGB = RGB(255, 255, 255)
.Weight = 1
.Transparency = 1
End With
With .Borders(ppBorderBottom)
.Visible = True
.ForeColor.RGB = RGB(0, 0, 0)
.Weight = 1
End With
With .Borders(ppBorderRight)
.Visible = False
.ForeColor.RGB = RGB(0, 0, 0)
.Weight = 1
.Transparency = 1
End With
End With
ElseIf iRow > 1 And iRow < (oTable.Rows.Count - 1) Then
'Format second to second-last rows
.Shape.TextFrame.TextRange.Font.Bold = False
' check if odd number
If Not iRow Mod 2 <> 0 Then
.Shape.Fill.ForeColor.RGB = RGB(235, 235, 235)
Else
.Shape.Fill.ForeColor.RGB = RGB(255, 255, 255)
End If
With oTable.Cell(iRow, iCol)
With .Borders(ppBorderLeft) 'Left
.Visible = msoFalse
.ForeColor.RGB = RGB(255, 255, 255)
.Weight = 1
.Transparency = 1
End With
With .Borders(ppBorderBottom) 'Bottom
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 255, 255)
.Weight = 1
.Transparency = 1
End With
With .Borders(ppBorderRight) 'Right
.Visible = msoFalse
.ForeColor.RGB = RGB(255, 255, 255)
.Weight = 1
.Transparency = 1
End With
End With
ElseIf iRow = (oTable.Rows.Count - 1) Then
'Apply different formatting to second-last row
.Shape.TextFrame.TextRange.Font.Bold = False
If Not iRow Mod 2 <> 0 Then
.Shape.Fill.ForeColor.RGB = RGB(235, 235, 235)
Else
.Shape.Fill.ForeColor.RGB = RGB(255, 255, 255)
End If
With oTable.Cell(iRow, iCol)
With .Borders(ppBorderLeft) 'Left
.Visible = msoFalse
.ForeColor.RGB = RGB(255, 255, 255)
.Weight = 1
.Transparency = 1
End With
With .Borders(ppBorderBottom) 'Bottom
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 0)
.Weight = 1
.Transparency = 0
End With
With .Borders(ppBorderRight) 'Right
.Visible = msoFalse
.ForeColor.RGB = RGB(255, 255, 255)
.Weight = 1
.Transparency = 1
End With
End With
Else
'Format last row
.Shape.Fill.ForeColor.RGB = RGB(255, 255, 255)
With oTable.Cell(iRow, iCol)
With .Borders(ppBorderTop)
.Visible = True
.ForeColor.RGB = RGB(0, 0, 0)
.Weight = 1
End With
With .Borders(ppBorderBottom)
.Visible = True
.ForeColor.RGB = RGB(0, 0, 0)
.Weight = 1
End With
End With
oTable.Cell(iRow, iCol).Shape.TextFrame.TextRange.Font.Bold = True
End If
End With
Next iCol
Next iRow
End If
End Sub
I'm making a VBA program that changes the visuals of the excel file. There are some tags ("BN", "A", "C" etc.) which say how the rows/cells should be changed.
For example: the tag "A" means - set the cell font to "Arial", size 13... etc.
The program was working until I made some changes a while ago. Since then it's giving me always an runtime error. Has anyone any clue as to why?
The code:
Option Explicit
Sub macro1()
Dim rowIndex As Integer
Dim lastRowIndex As Integer
Dim offset As Integer
lastRowIndex = 2700
With ActiveSheet
For rowIndex = 1 To 3
Rows(1).EntireRow.Delete
Next rowIndex
With Cells.Font
.Name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Bold = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
End With
With Cells
.RowHeight = 11
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns(1).ColumnWidth = 13.5
Columns(2).ColumnWidth = 60
With Columns(3)
.HorizontalAlignment = xlCenter
.ColumnWidth = 5.5
End With
With Columns(4)
.HorizontalAlignment = xlRight
.ColumnWidth = 6.5
End With
With Columns(5)
.HorizontalAlignment = xlRight
.ColumnWidth = 6.5
End With
Columns(4).HorizontalAlignment = xlRight
Columns(5).HorizontalAlignment = xlRight
rowIndex = 1
offset = 0
Do While (rowIndex - offset) < lastRowIndex
If Cells(rowIndex, 5).Value = "A" Or Cells(rowIndex, 5).Value = "NAZOV" Or _
Cells(rowIndex, 5).Value = "C" Or Cells(rowIndex, 6).Value = "BN" Then
If Cells(rowIndex, 5).Value = "A" Then
Cells(rowIndex, 5).ClearContents
With Cells(rowIndex, 2).Font
.Name = "Arial Narrow"
.Size = 11
.Bold = True
.Color = RGB(204, 0, 0)
End With
With Cells(rowIndex, 2)
.RowHeight = 16
.HorizontalAlignment = xlCenter
End With
End If
If Cells(rowIndex, 5).Value = "NAZOV" Then
Cells(rowIndex, 5).ClearContents
With Cells(rowIndex, 2).Font
.Name = "Arial"
.Size = 9
.Bold = True
.Underline = xlUnderlineStyleSingle
.Color = RGB(0, 0, 153)
End With
With Cells(rowIndex, 2)
.RowHeight = 13
End With
End If
If Cells(rowIndex, 5).Value = "C" Then
Cells(rowIndex, 5).ClearContents
Cells(rowIndex, 6).ClearContents
Cells(rowIndex, 7).ClearContents
With Cells(rowIndex, 2).Font
.Name = "Arial Narrow"
.Size = 8
.Italic = True
.ColorIndex = 16
End With
With Cells(rowIndex, 2)
.RowHeight = 12
End With
End If
If Cells(rowIndex, 6) = "BN" Then
Cells(rowIndex, 6).ClearContents
If (Cells(rowIndex + 1, 5) <> "C") Then
Rows(rowIndex + 1).Insert
With Rows(rowIndex + 1)
.RowHeight = 3
.Font.Size = 2
End With
offset = offset + 1
Else
Rows(rowIndex + 2).Insert
With Rows(rowIndex + 2)
.RowHeight = 3
.Font.Size = 2
End With
offset = offset + 2
End If
End If
Else
Cells(rowIndex, 2).WrapText = True
Rows(rowIndex).AutoFit
End If
If Cells(rowIndex, 6).Value = "D" Then
Cells(rowIndex, 6).ClearContents
With Selection.Font
.Underline = xlUnderlineStyleSingle
.Bold = True
.Italic = False
End With
End If
If Cells(rowIndex, 6).Value = "E" Then
With Selection.Font
.Underline = xlUnderlineStyleSingle
.Bold = False
End With
End If
If Cells(rowIndex, 5).Value = "P" Then
Cells(rowIndex, 5).ClearContens
End If
If ( _
((Cells(rowIndex, 5) = Cells(rowIndex - 1, 5)) Or (Cells(rowIndex, 5) = Cells(rowIndex - 2, 5))) And _
((Cells(rowIndex, 4) = "" And Cells(rowIndex - 1, 4) <> "") Or (InStr(Cells(rowIndex, 2).Text, ">"))) And _
(Cells(rowIndex - 1, 2).Font.Size = 9) Or (Cells(rowIndex, 2).Font.Size = 9 And Cells(rowIndex - 1, 2).Font.Size = 9)) Then
With Cells(rowIndex, 2).Font
.Italic = True
.ColorIndex = 16
.Bold = False
.Size = 8
.Underline = False
End With
Cells(rowIndex, 2).WrapText = True
Rows(rowIndex).AutoFit
End If
rowIndex = rowIndex + 1
Loop
End With
End Sub
The runtime error appears on the last IF statement:
If ( _
((Cells(rowIndex, 5) = Cells(rowIndex - 1, 5)) Or (Cells(rowIndex, 5) = Cells(rowIndex - 2, 5))) And _
((Cells(rowIndex, 4) = "" And Cells(rowIndex - 1, 4) <> "") Or (InStr(Cells(rowIndex, 2).Text, ">"))) And _
(Cells(rowIndex - 1, 2).Font.Size = 9) Or (Cells(rowIndex, 2).Font.Size = 9 And Cells(rowIndex - 1, 2).Font.Size = 9)) Then
I have got this code:
With .Cells(i, 4)
If .Value > 0.8 Then
.Interior.Color = RGB(237, 67, 55) '<-- Red color
.Font.Color = vbWhite
ElseIf .Value > 0.6 Then
.Interior.Color = RGB(255, 190, 0) '<-- Amber Colour
.Font.Color = vbWhite
ElseIf .Value2 = "---" Then
.Interior.Color = .Interior.Color
Else
.Interior.Color = RGB(50, 205, 50) '<-- Green color
.Font.Color = vbWhite
End If
End With
The worksheet is already formatted to have alternating row colours by default but pending on the values of the cell the interior cell colour needs to change pending on the value of the cell but, some cells don't have numerical data and just "---". When this is the case I want the original formatting to remain as it was before the code was run.
Basically, If the cell contains "---" don't assign any other interior colour, but keep the colour already assigned.
I tested this and it seemed to work on my test data, for some reason excel is treating "---" as a value larger than 0.8 so moving the check for "---" first will stop this.
With .Cells(i, 4)
If .Value = "---" Then
.Interior.Color = .Interior.Color
ElseIf .Value > 0.8 Then
.Interior.Color = RGB(237, 67, 55) '<-- Red color
.Font.Color = vbWhite
ElseIf .Value > 0.6 Then
.Interior.Color = RGB(255, 190, 0) '<-- Amber Colour
.Font.Color = vbWhite
Else
.Interior.Color = RGB(50, 205, 50) '<-- Green color
.Font.Color = vbWhite
End If
End With
I have got a list of percentage values that are really small (0.000% format), this represents the error percentage of routers. i want to format the cell color depending on the amount on the cell. if the amount is more than 0.050% it should be Red, if it is more than 0.005% is amber, everything else is green
here is the code that i have written:
With .Cells(i, 8)
If .NumberFormat <> "0.000%" Then
.NumberFormat = "0.000%"
If .Value2 <> vbNullString And IsNumeric(.Value2) Then .Value = .Value / 100
If .Value2 = vbNullString Then
.Value = "---"
.HorizontalAlignment = xlRight
End If
Else
.Value = 0
End If
If .Value > 0.05 Then
.Interior.Color = RGB(237, 67, 55) '<-- Red color
.Font.Color = vbWhite
ElseIf .Value > 0.005 Then
.Interior.Color = RGB(255, 190, 0) '<-- Amber Colour
.Font.Color = vbWhite
Else
.Interior.Color = RGB(50, 205, 50) '<-- Green color
.Font.Color = vbWhite
End If
End With
but the colour format is not accurate, here is the list of some of the results:
0.034% <---green
0.845% <---amber
0.007% <---green
0.005% <---green
0.094% <---green
it should not be like that as the cell that contains 0.845% and is amber should be bright red!
The value stored is not a percentage. It is the decimal equivalent, meaning you must shift the decimal point two places to the left. So to compare 0.05% you must use 0.0005.
This should clean up the code for you to make it a bit faster too:
Sub Test()
Dim Cel As Range, Rng As Range
Set Rng = Range("H1:H" & Range("H1048576").End(xlUp).Row).SpecialCells(xlCellTypeConstants)
For Each Cel In Rng
If Trim(Cel.Value) = "" Then Cel.Value = "---": Cel.HorizontalAlignment = xlRight
If IsNumeric(Cel.Value) Then
Cel.Value = Cel.Value / 100
If Cel.Value > 0.0005 Then
Cel.Interior.Color = RGB(237, 67, 55): Cel.Font.Color = vbWhite
ElseIf Cel.Value > 0.00005 Then
Cel.Interior.Color = RGB(255, 190, 0): Cel.Font.Color = vbWhite
Else: Cel.Interior.Color = RGB(50, 205, 50): Cel.Font.Color = vbWhite
End If
End If
Next
With Range("H1:H" & Range("H1048576").End(xlUp).Row).SpecialCells(xlCellTypeBlanks)
.Value = "---"
.HorizontalAlignment = xlRight
End With
End Sub
I'm just after realizing Paul corrected your question....
I am trying to make Excel cells look like buttons without actually inserting buttons.
For Each myCell In Range(BoardSize)
With myCell
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThick
.Borders.Color = RGB(110, 110, 110)
.Interior.Color = RGB(180, 180, 180)
End With
myCell.Borders(xlEdgeTop).Color = RGB(255, 255, 255)
myCell.Borders(xlEdgeLeft).Color = RGB(255, 255, 255)
Next myCell
It works for one cell:
but in a large range it looks like this:
What I want is something, without using actual command buttons, like:
For Each mycell In Range(BoardSize)
isblack = mycell.Row Mod 2 = 0 Xor mycell.Column Mod 2 = 0
With mycell
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThick
.Borders.Color = RGB(110, 110, 110)
.Interior.Color = RGB(180, 180, 180)
End With
If Not isblack Then
mycell.Borders(xlEdgeTop).Color = RGB(255, 255, 255)
mycell.Borders(xlEdgeLeft).Color = RGB(255, 255, 255)
End If
Next mycell
Another version with a minor artifact. It skipps odd rows and odd columns
Dim mycell As Range
For Each mycell In Range(BoardSize)
evenrow = mycell.Row Mod 2 = 0
evencol = mycell.Column Mod 2 = 0
isblack = evenrow Xor evencol
With mycell
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThick
.Borders.Color = RGB(110, 110, 110)
.Interior.Color = RGB(180, 180, 180)
End With
If Not isblack Then
mycell.Borders(xlEdgeTop).Color = RGB(255, 255, 255)
mycell.Borders(xlEdgeLeft).Color = RGB(255, 255, 255)
End If
If evenrow Or evencol Then mycell.Borders.Color = RGB(180, 180, 180)
If evencol And mycell.ColumnWidth <> 0.1 Then mycell.ColumnWidth = 0.1 Else mycell.ColumnWidth = 5
If evenrow And mycell.RowHeight <> 1 Then mycell.RowHeight = 1 Else mycell.RowHeight = 30
Next mycell