VBA applying conditional formatting to cell - vba

I'm trying to add conditional formatting to a range that checks cell X1 and if it doesn't match it applies the conditions.
If i apply it to one cell it works great. however i need it applied to each cell in a range.
code:
Function FindComment(rng As Range, strSearch As String) As Boolean
On Error GoTo err_h:
strSearch = LCase(strSearch)
If Len(strSearch) = 0 Then
FindComment = False
Exit Function
End If
If InStr(1, rng.Comment.Text, strSearch, vbTextCompare) > 0 Or InStr(1, rng.Text, strSearch, vbTextCompare) > 0 Then
FindComment = False
Exit Function
End If
FindComment = True
Exit Function
err_h:
FindComment = True
End Function
And to apply the conditional formatting:
Public Sub AddConditionalFormat(rng As Range)
rng.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=FINDCOMMENT(" & rng.Address(, , xlA1) & ",$X$1)"
rng.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font
.ColorIndex = 2
End With
With rng.FormatConditions(1).Interior
.Pattern = xlGray75
.PatternThemeColor = xlThemeColorDark2
.PatternTintAndShade = 0
.ColorIndex = 2
.TintAndShade = 0
.PatternTintAndShade = 0
End With
rng.FormatConditions(1).StopIfTrue = False
End Sub
the range range("B6:GD9") are determined as rng.
currently if the results match it just blanks out all cells including the match.
anyone have an idea of how to easily fix? i'd prefer something that would not lag out the code by applying to each cell etc.

The Range.Address property defaults to absolute row and column references. You are looking for something like A1 but you are getting $A$1.
rng.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=FINDCOMMENT(" & rng.Cells(1, 1).Address(RowAbsolute:=False, ColumnAbsolute:=False, ReferenceStyle:=xlA1) & ", $X$1)"
'alternate in shorthand
rng.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=FINDCOMMENT(" & rng.Cells(1, 1).Address(0, 0, xlA1) & ", $X$1)"
Using .Cells(1, 1) should make that formula reference the upper left cell in rng.

Related

Setting formatconditions doesn't work with certain ranges?

I have the following code:
i = i + 1
StrSearchCriteria = "=($W1=" & Chr(34) & "ETF" & Chr(34) & ")"
With .Range("A:A").FormatConditions
.Add Type:=2, Formula1:=StrSearchCriteria
With .Item(i)
.SetFirstPriority
With .Interior
.PatternColorIndex = xlAutomatic
.Color = RGB(225, 225, 0)
End With
.StopIfTrue = False
End With
End With
This does not set the format conditions. The rule is there and the range, criteria are correct, but the format conditions are "No Format Set".
HOWEVER.... if I change
With .Range("A:A").FormatConditions
to
With .Range("E:E").FormatConditions
It works...
"B:B", "C:C", "D:D" all fail with the same issue.
Using "E:E" (and I also tried "F:F" which worked), I can then open the workbook and manually change the range to "A:A", "B:B", "C:C" or "D:D" and it works.
I then tried "A:E", which also worked. It appears that if I use any part of column E through W (last column) it works, but if I don't include anything from E and following it fails.
Totally confused here. Any ideas?
Is there a merged cell range in A:D?
I believe #mer_curius hit on the issue - merged cells.
So, as a work around, since I only want A:A to have the coloring and I need to set the condition to A:E, I follow that rule with setting a rule with the same criteria and no-fill B:E.
The code that works looks like this:
i = 1
StrSearchCriteria = "=($W1=" & Chr(34) & "ETF" & Chr(34) & ")"
strRange = "A:E"
With .Range(strRange).FormatConditions
.Add Type:=2, Formula1:=StrSearchCriteria
With .Item(i)
.SetFirstPriority
With .Interior
.PatternColorIndex = xlAutomatic
.Color = RGB(225, 225, 0)
End With
.StopIfTrue = False
End With
End With
i = i + 1
StrSearchCriteria = "=($W1=" & Chr(34) & "ETF" & Chr(34) & ")"
strRange = "B:E"
With .Range(strRange).FormatConditions
.Add Type:=2, Formula1:=StrSearchCriteria
With .Item(i)
.SetFirstPriority
With .Interior
.Pattern = xlNone
End With
.StopIfTrue = False
End With
End With

Conditional formatting for highlighting top 2 values for each row for visibile cells only

I am trying to highlight top 2 values for each row for visible cells only using conditional formatting in Excel macro. My range is dynamic, hence I am running a loop to arrive at the last cell of the range.
Here is my code:
With Sheets("pcSupplyChainAnalysis").Select
For i = 2 To ctr
Set rng = Range("C" & i & ":" & "I" & i).SpecialCells(xlCellTypeVisible)
rng.FormatConditions.AddTop10
rng.FormatConditions(rng.FormatConditions.Count).SetFirstPriority
With rng.FormatConditions(1)
.TopBottom = xlTop10Top
.Rank = 2
.Percent = False
End With
With rng.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
End With
rng.FormatConditions(1).StopIfTrue = False
Next
End With
Ctr is a counter I am running to find the position of the last non blank cell, as my data has blank values too and I am copying it from another sheet using macro.
ctr = 2
Do While (ActiveSheet.Range("A" & ctr).Value <> "")
ctr = ctr + 1
Loop
ctr = ctr - 1
ActiveSheet.Range("B2:I" & ctr).Select
Selection.Cut
Range("C2:J" & ctr).Select
ActiveSheet.Paste
Attached is the image of the format of my data. I want to highlight top 2 numbers for each row and ONLY FOR VISIBLE CELLS (as I am using some filters also in the range).
Try this:
Option Explicit
Public Sub ShowTop2()
Dim rng As Range, visibleRow As Range
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("pcSupplyChainAnalysis")
.Columns.FormatConditions.Delete
Set rng = .UsedRange.SpecialCells(xlCellTypeVisible)
End With
For Each visibleRow In rng.Rows
If visibleRow.Row > 1 Then
With visibleRow.FormatConditions
.AddTop10
.Item(.Count).SetFirstPriority
With .Item(1)
.TopBottom = xlTop10Top
.Rank = 2
.Interior.Color = 255
End With
End With
End If
Next
Application.ScreenUpdating = True
End Sub
An easier way to determine the last used row in column A:
ctr = Worksheets("pcSupplyChainAnalysis").Cells(Rows.Count, "A").End(xlUp).Row
You don't need to Select anything for any of your actions

Highlight Row-Column of selected cell

Be gentle guys, I'm not a programmer.
I got this snippit of code off the internet many many moons ago. I would give credit, but I don't remember where it came from.
Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Static xRow
Static xColumn
If xColumn <> "" Then
With Columns(xColumn)
.Interior.ColorIndex = xlNone
End With
With Rows(xRow)
.Interior.ColorIndex = xlNone
End With
End If
pRow = Selection.Row
pColumn = Selection.Column
xRow = pRow
xColumn = pColumn
With Columns(pColumn)
.Interior.ColorIndex = 19
.Interior.Pattern = xlSolid
End With
With Rows(pRow)
.Interior.ColorIndex = 19
.Interior.Pattern = xlSolid
End With
End Sub
The above code highlights rows and columns of a selected sell. The problem is that it highlights columns from 1 to 1048576, which causes the vertical scroll bar to get tiny. Plus if there is any color coding in the spreadsheet it screws that up. I decided to write my own highlighter. I put a border around my selected row,column and only do it for 500 rows. It works, almost. The problem is that something in my code cancels the copy command, and will not allow me to paste, which did not happen in the code above. Copy/Paste is a must. Any help would be greatly appreciated.
Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Range("A1:N500").Borders(xlEdgeLeft).Weight = xlThin
Range("A1:N500").Borders(xlEdgeTop).Weight = xlThin
Range("A1:N500").Borders(xlEdgeBottom).Weight = xlThin
Range("A1:N500").Borders(xlEdgeRight).Weight = xlThin
Range("A1:N500").Borders(xlInsideVertical).Weight = xlThin
Range("A1:N500").Borders(xlInsideHorizontal).Weight = xlThin
Range("A1:N500").Borders(xlEdgeLeft).Color = vbBlack
Range("A1:N500").Borders(xlEdgeTop).Color = vbBlack
Range("A1:N500").Borders(xlEdgeBottom).Color = vbBlack
Range("A1:N500").Borders(xlEdgeRight).Color = vbBlack
Range("A1:N500").Borders(xlInsideVertical).Color = vbBlack
Range("A1:N500").Borders(xlInsideHorizontal).Color = vbBlack
Dim SplitAddress() As String
SplitAddress = Split(ActiveCell.Address, "$")
Dim RowSelection As String
RowSelection = "A" & SplitAddress(2) & ":" & "N" & SplitAddress(2)
Dim ColSelection As String
ColSelection = SplitAddress(1) & "1" & ":" & SplitAddress(1) & "500"
With Range(RowSelection)
.BorderAround Weight:=xlThick, Color:=RGB(255, 0, 0)
End With
With Range(ColSelection)
.BorderAround Weight:=xlThick, Color:=RGB(255, 0, 0)
End With
End Sub
try this.
it is work in progress
it copies the format, as the default format, from the very last cell in worksheet
the code uses no copy/paste to do the borders
i am still working on copy/paste between cells that you are having trouble with
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.ScreenUpdating = False
Dim aaa As DisplayFormat
Set aaa = Range("XFD1048576").DisplayFormat ' copy format from very last cell (it is a cheat)
Range("A1:N500").Borders.Color = aaa.Borders.Color ' revert border color to its default
Range("A1:N500").Borders.LineStyle = aaa.Borders.LineStyle
Dim i As Integer
For i = xlEdgeLeft To xlEdgeRight ' loop the four outside borders (7 to 10)
Target.EntireRow.Resize(1, 8).Borders.Item(i).Color = vbRed
Target.EntireRow.Resize(1, 8).Borders.Item(i).Weight = xlThick
Target.EntireColumn.Resize(500, 1).Borders.Item(i).Color = vbRed
Target.EntireColumn.Resize(500, 1).Borders.Item(i).Weight = xlThick
Next i
Application.ScreenUpdating = True
End Sub

Conditionally formatting a looped range of cells based on value in other cell in VBA

I am trying to conditionally format a range of cells based on the number in the column to each cell groupings' left. Basically, if in row 13, the gray column to the left of each cell grouping = 0, then I want the whole cell grouping to its right to turn green, if = 15, turn yellow, if = 25 turn red. Row 12 is what is happening with my code right now and row 13 is what I want it to look like. I can't seem to get the loop correct.
Sub Highlight3()
For i = 1 To ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row
If Cells(i, 4) = "Highlight" Then
For j = 1 To 15
Range(Cells(i, j * 4 + 2), Cells(i + 1, j * 4 + 4)).Select
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=$E$23 = 0"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.Color = rgbRed
End With
Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=$E$23= 15"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.Color = rgbGold
End With
Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=$E$23 = 25"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.Color = rgbGreen
End With
Next j
End If
Next i
End Sub
Avoid Select because it's slow and unyieldy. Just directly assign your Ranges to variables and work with those.
Sub Highlight3()
For i = 1 To ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row Step 2
If Cells(i, 4) = "Highlight" Then
For j = 1 To 15
Dim r As Range
Set r = Range(Cells(i, j * 4 + 2), Cells(i + 1, j * 4 + 4))
Dim checkAddress As String
checkAddress = Cells(i, j * 4 + 1).Address
With r.FormatConditions
.Delete
.Add Type:=xlExpression, Formula1:="=" & checkAddress & " = 0"
.Item(.Count).Interior.Color = rgbRed
.Add Type:=xlExpression, Formula1:="=" & checkAddress & " = 15"
.Item(.Count).Interior.Color = rgbGold
.Add Type:=xlExpression, Formula1:="=" & checkAddress & " = 25"
.Item(.Count).Interior.Color = rgbGreen
End With
Next j
End If
Next i
End Sub
Things to notice:
No more ugly use of selection - get the Range r once and do all the tasks with its conditional formatting in one clean block.
No longer sets the new conditional formats to have first priority. Edit that back in if necessary, but I was guessing that it was just something that the Macro Recorder did.
Builds the formatting formula to check against the address directly left of the first cell. Make sure that the expression for checkAddress is what you'd expect, because I had to infer it from your picture and code. If that area with the value 0/15/25 is actually two merged cells (kinda looks like it is), then make sure this formula is for the upper cell, because that cell will be the one that actually holds the value.
Again, hard to tell from just a picture, but it looks like each of your "rows" is actually two cells high (based on your code, too). So you actually want to step through values of i by 2 at a time, not 1 at a time.
If any of the assumptions I've just listed about your table's formatting are wrong, let me know and I'll help iron out any remain kinks in the code.
This should do what you want and also be a bit faster:
Sub Highlight3()
Dim i As Long, j As Byte, myCols As Range, myRng As Range
Set myCols = Range("$B:$D")
For i = 1 To ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row
If Cells(i, 4) = "Highlight" Then
If myRng Is Nothing Then
Set myRng = Intersect(Rows(i), myCols)
Else
Set myRng = Union(myRng, Intersect(Rows(i), myCols))
End If
i = i + 1 'skip the line after, because it will never have a value / merged cell
End If
Next
If myRng Is Nothing Then Exit Sub
For i = 4 To 60 Step 4
For j = 0 To 1
With myRng.Offset(j, i)
.Cells(1).Offset(-j).Activate
.FormatConditions.Delete 'if that does not interfer with other stuff, better use the next line
'If j = 0 Then myCols.Offset(, i).FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:="=" & .Cells(1).Offset(-j, -1).Address(0) & "=0"
.FormatConditions(.FormatConditions.Count).SetFirstPriority
.FormatConditions(1).Interior.Color = rgbRed
.FormatConditions.Add Type:=xlExpression, Formula1:="=" & .Cells(1).Offset(-j, -1).Address(0) & "=15"
.FormatConditions(.FormatConditions.Count).SetFirstPriority
.FormatConditions(1).Interior.Color = rgbGold
.FormatConditions.Add Type:=xlExpression, Formula1:="=" & .Cells(1).Offset(-j, -1).Address(0) & "=25"
.FormatConditions(.FormatConditions.Count).SetFirstPriority
.FormatConditions(1).Interior.Color = rgbGreen
End With
Next
Next
End Sub
tested it locally and it worked... there may be issues which I can not know (better test it with a copy of your workbook).
The first part pushes all lines in a range which is used in the second part. This way, each pack of columns needs only 2 steps (no need to run EVERY line).
If you have any questions or problems with this code, just ask ;)

How can I use .EntireRow but skip column A?

Looking for either a workaround or some idea on how I can use the code excerpt below, but skip column A.
Basically, I'm using
.EntireRow(a.Row).Interior.Color = color
to highlight rows based on a userform selection, but I need to skip column A as it has headers that have their own highlighting.
Any ideas?
If ToggleButton3.Value = True Then
On Error Resume Next
For iRow = 1 To 15
If Sheets("Prop" & iRow).Visible <> xlSheetVisible Then
Else
With Sheets("Prop" & iRow).Range("$E$1:$E$157")
Set a = .Find(SlctdPAX, LookIn:=xlValues, LookAt:=xlWhole)
.EntireRow(a.Row).Interior.Color = RGB(255, 255, 102) 'yellow
End With
End If
Next iRow
ElseIf ToggleButton1.Value = True Then
On Error Resume Next
For iRow = 1 To 15
If Sheets("Prop" & iRow).Visible <> xlSheetVisible Then
Else
With Sheets("Prop" & iRow).Range("$E$1:$E$157")
Set a = .Find(SlctdPAX, LookIn:=xlValues, LookAt:=xlWhole)
.EntireRow(a.Row).Interior.Color = RGB(255, 0, 0) 'red
End With
End If
Next iRow
ElseIf ToggleButton4.Value = True Then
On Error Resume Next
For iRow = 1 To 15
If Sheets("Prop" & iRow).Visible <> xlSheetVisible Then
Else
With Sheets("Prop" & iRow).Range("$E$1:$E$157")
Set a = .Find(SlctdPAX, LookIn:=xlValues, LookAt:=xlWhole)
.EntireRow(a.Row).Interior.Color = xlNone 'no fill
End With
End If
Next iRow
ElseIf ToggleButton2.Value = True Then
On Error Resume Next
For iRow = 1 To 15
If Sheets("Prop" & iRow).Visible <> xlSheetVisible Then
Else
With Sheets("Prop" & iRow).Range("$E$1:$E$157")
Set a = .Find(SlctdPAX, LookIn:=xlValues, LookAt:=xlWhole)
.EntireRow(a.Row).Interior.Color = RGB(128, 255, 0) 'green
End With
End If
Next iRow
Else
End If
Lets say a is a single cell.
With regards to exclude highlighting column A,
to highlight entire row of a, do:
a.EntireRow.Resize(, Columns.Count - 1).Offset(, 1).Interior.Color
to highlight multiple rows staked together below a, e.g. 5 rows, do:
a.EntireRow.Resize(5, Columns.Count - 1).Offset(, 1).Interior.Color
to highlight multiple rows which are not staked together, e.g. entire rows of [E1], [E3], [E5], do:
Intersect(Union([E1], [E3], [E5]).EntireRow, Cells.Resize(, Columns.Count - 1).Offset(, 1))
FYI, just tested that Union([E1], [E3], [E5]).EntireRow.Resize() is not allowed.
Hope this helps.
With ThisWorkbook.Sheets("Prop" & iRow)
Set a = .Range("$E$1:$E$157").Find(SlctdPAX, LookIn:=xlValues, LookAt:=xlWhole)
a.EntireRow.Resize(1, .Cells(a.row, .Columns.Count - 1).column).Offset(, 1).Interior.Color = RGB(255, 0, 0) 'red
End With
which is quite much whar KS Sheon has already posted.
but I'm afraid his code, being inside With Sheets("Prop" & iRow).Range("$E$1:$E$157") block , would color all rows from 1 to 157.
moreover Columns.Count would count the number of columns of the active sheet, which may not be the one wanted