Color cells with specific data - excel

I have a macro to color cells that have the word VOID in it.
I also have the word VOID in a cell like this: [$189.00VOID].
I can't find a way to color all cells that contain:
VOID and [$189.00VOID]
or any other dollar amount in it.
Sub Macro1()
On Error Resume Next
Dim current As String
For i = 1 To 65536 ' go from first cell to last
current = "c" & i ' cell counter
Range(current).Select ' visit the current cell
If Range(current).Text = "VOID" Then ' if it says VOID then we...
With Selection.Interior
.ColorIndex = 3 ' ...go red
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
End If
If Range(current).Text = "FORWARDED" Then ' if it says FORWARDED then we...
With Selection.Interior
.ColorIndex = 4 ' ...go green
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
End If
Next i ' loop and check the next cell
End Sub

VBA really seems like overkill for this. As pnuts said, conditional formatting will do everything you need.
Select the cell(s) you want to format, then Home Ribbon -> Conditional Formatting -> New Rule -> Format Only Cells that Contain
Then change the first combo box from Cell Value to specific text. and in the empty text box on the right type VOID.
You can then adjust the cell formatting to be whatever you want.

For something like this, I would really recommend using conditional formatting (as has already been stated). Here are the two Condtional Format formulas that you would need to apply to column C:
=COUNTIF($C1,"*VOID*")>0
=COUNTIF($C1,"*FORWARDED*")>0
However, if it absolutely has to be VBA, then right-click the sheet tab that you want to monitor and select "View Code". In there, paste the following:
Private Sub Worksheet_Calculate()
Dim rngColor As Range
Dim rngFound As Range
Dim strFirst As String
Dim varFind As Variant
'Remove current formatting (if any)
Columns("C").Interior.Color = xlNone
'Check for both VOID and FORWARDED
For Each varFind In Array("VOID", "FORWARDED")
'Attempt to find a cell that contains varFind
Set rngFound = Columns("C").Find(varFind, Me.Cells(Me.Rows.Count, "C"), xlValues, xlPart)
'Check if any cells were found
If Not rngFound Is Nothing Then
'The first cell was found, record its address and start rngColor
strFirst = rngFound.Address
Set rngColor = rngFound
'Begin loop
Do
'Add found cell to rngColor
Set rngColor = Union(rngColor, rngFound)
'Advance loop by finding the next cell
Set rngFound = Columns("C").Find(varFind, rngFound, xlValues, xlPart)
'Exit loop when back to first cell
Loop While rngFound.Address <> strFirst
'Fill rngColor based on varFind
Select Case varFind
Case "VOID": rngColor.Interior.Color = vbRed
Case "FORWARDED": rngColor.Interior.Color = vbGreen
End Select
End If
Next varFind
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Worksheet_Calculate
End Sub

Related

How do I removed Conditional Formatting after its been applied?

I have a worksheet change macro that highlights the first 8 cells in a row if the last cell contains the word "Cancelled". This works fine. However the word cancelled is in a drop down menu and if you accidently select it the macro kicks in. If you change to another word in the same cell, I would like it to remove the condition and go back to normal. Can someone help me out with this. Im sure it is something simple that I'm missing.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ErrHandler
If UsedRange.Rows.Count > 0 Then
If Trim(Cells(Target.Row, Target.Column)) <> "" And _
UCase(Cells(Target.Row, Target.Column)) = "CANCELLED" Then
Range(Cells(Target.Row, 1), Cells(Target.Row, 8)).Interior.Color = vbRed
Range(Cells(Target.Row, 1), Cells(Target.Row, 8)).Font.Color = vbWhite
ElseIf Trim(Cells(Target.Row, Target.Column)) <> "" And _
UCase(Cells(Target.Row, Target.Column)) <> "CANCELLED" Then
Cells.FormatConditions.Delete
End If
End If
ErrHandler:
'
End Sub
You don't "apply" and "remove". You "apply" in both cases, just that you apply different colours.
Private Sub Worksheet_Change(ByVal Target As Range)
Const TriggerClm As Long = 8 ' change to suit
Dim TriggerRng As Range
Dim TargetRng As Range
Dim IntCol As Long
' Here the first row is 2, presuming row 1 contains captions
Set TriggerRng = Range(Cells(2, TriggerClm), Cells(Rows.Count, TriggerClm).End(xlUp))
If Not Application.Intersect(Target, TriggerRng) Is Nothing Then
With Target
Set TargetRng = Range(Cells(.Row, TriggerClm - 7), Cells(.Row, TriggerClm))
If StrComp(CStr(.Value), "cancelled", vbTextCompare) Then
TargetRng.Interior.Pattern = xlNone
TargetRng.Font.Color = vbBlack
Else
TargetRng.Interior.Color = vbRed
TargetRng.Font.Color = vbWhite
End If
End With
End If
End Sub
Observe that I reasoned that a change can only be triggered if a cell in the 8th column is changed because only that cell is either "Cancelled" or not. My code's logic deviates from yours in this respect.

Get cell formatting

Is there a function to get the activecell formatting? e.g. background color, font, font color, cell border, font size etc.
I want to update the format of an entire worksheet based on a formatted cell before action (i.e. the format I want to change) by another formatted cell (i.e. the format I want to apply).
Sub Rep_all_format()
Dim fmt_bef As CellFormat
Dim fmt_aft As CellFormat
Dim rngReplace As Boolean
Dim msg As String
Dim Sh As Worksheet
Dim Rg As Range
Dim ppos1 As Range
Dim ppos2 As Range
Dim Find As String
Dim Remplace As String
Set ppos1 = Application.InputBox(Prompt:="Select the cell format you wanna change", Title:="Remplace", Default:=ActiveCell.Address, Type:=8)
Set ppos2 = Application.InputBox(Prompt:="Select the cell format you wanna apply", Title:="Select", Type:=8)
Find = ppos1.FormatConditions 'this is theorical I do not know the function
Remplace = ppos2.FormatConditions 'this is theorical I do not know the function
Application.ScreenUpdating = False
Set fmt_bef = Application.FindFormat
Set fmt_aft = Application.ReplaceFormat
For Each Sh In ThisWorkbook.Worksheets
Set Rg = Sh.UsedRange
With fmt_bef
.Clear
.FormatConditions = Find
End With
With fmt_aft
.Clear
.FormatConditions = Remplace
End With
Rg.Replace What:="", Replacement:="", _
SearchFormat:=True, ReplaceFormat:=True
Next
fmt_bef.Clear
fmt_aft.Clear
Application.ScreenUpdating = True
MsgBox ("The desired format has been applied through all the workbook")
End Sub
Assuming, from the code that you have provided, that your cell has been formatted using Conditional Formatting, you need to access is the Range.DisplayFormat property.
Note that I showed only some of the formatting options for a cell. There is documentation online for other formatting options (eg other borders, numberformat, etc) but this should get you started.
For example:
Option Explicit
Sub foo()
Dim R As Range, C As Range
Dim fc As FormatCondition
Set R = Range(Cells(1, 1), Cells(5, 1))
For Each C In R
With C.DisplayFormat
Debug.Print .Interior.Color
Debug.Print .Font.Name
Debug.Print .Font.Color
Debug.Print .Borders(xlEdgeLeft).LineStyle ' etc
Debug.Print .Font.Size
End With
Stop
Next C
End Sub
If the cell has been formatted manually, or directly using code, then just access the various properties directly, not using the DisplayFormat property eg:
For Each C In R
With C
Debug.Print .Interior.Color
Debug.Print .Font.Name
Debug.Print .Font.Color
Debug.Print .Borders(xlEdgeLeft).LineStyle ' etc
Debug.Print .Font.Size
End With
Stop
Next C
What you are looking for are the Range.Interior and Range.Font properties etc.
You can see some examples in the links below:
https://learn.microsoft.com/en-us/office/vba/api/excel.font(object)
https://learn.microsoft.com/en-us/office/vba/api/excel.interior(object)
https://learn.microsoft.com/en-us/office/vba/api/excel.border(object)

How to check for duplicates, highlight duplicates, and count the highlighted duplicates in a single column?

I want to highlight and count the number of duplicates in a single concatenated column.
I have it as two separate subs right now and there really isn't much more to say, this isn't that hard of a problem I'm confident of that but I have been working on it for days with absolutely no progress. It has to be done in a VBA and it cannot highlight blank cells in the column. The concatenations are done through a formula in the workbook. Please help me, I m dying,
Sub Duplicate_Check()
Dim ws As Worksheet
Set ws = Sheet1
Worksheets("Master Checklist").Activate
Columns("H:H").Select
Selection.FormatConditions.AddUniqueValues
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).DupeUnique = xlDuplicate
With Selection.FormatConditions(1).Interior
.ColorIndex = 40
.TintAndShade = 0
End With
'Sheet2.Range(“L2").Value = Application.WorksheetFunction.Countif(Columns("H:H")), cell.Font.Color = "-16383844")
'Range(“B10?).Value = Application.WorksheetFunction.Countif(Range(“A2:A8?), “>” & 50
End Sub
Sub CountDupes()
Dim countofDupes As Long
Dim rng As Range
Dim myCell As Range
countofDupes = 0
Set rng = Range("H2").End(xlDown)
For Each myCell In rng
If myCell.Interior.ColorIndex = 40 Then
countofDupes = countofDupes + 1
Debug.Print countofDupes
End If
Next myCell
End Sub
I don't encounter any error messages but if I Debug.Print countofDupes I get nothing returned, which it obviously not what I want. Any advice?

How to alter the color of cells if they are a certain other color?

I have written a short Macro to change cells of a given colour to another colour in a workbook. This code throws no errors however it simply does nothing.
I have already tested the colour codes to see if they are correct using MsgBox ActiveCell.DisplayFormat.Interior.color
Option Explicit
Sub Recolour()
Application.ScreenUpdating = False
Dim Sheet As Worksheet
Dim Rng As Range
Dim OldColour As Variant
Dim NewColour As Variant
Dim Cell As Range
Set Rng = ActiveSheet.Range("A1:Y457")
OldColour = 128
NewColour = RGB(134, 38, 51)
For Each Sheet In ThisWorkbook.Worksheets
For Each Cell In Rng.Cells
If ActiveCell.DisplayFormat.Interior.Color = OldColour _
Then _
Set ActiveCell.DisplayFormat.Interior.Color = NewColour _
Else
Next Cell
Next Sheet
Application.ScreenUpdating = True
End Sub
This is probably something simple and daft however I need to ask.
DisplayFormat is read-only. If you want to change the property, you need to drop DisplayFormat. Also, if you are using For each Cell, then you should refer to Cell, not ActiveCell.
For Each Sheet In ThisWorkbook.Worksheets
For Each Cell In Rng.Cells
If Cell.Interior.color = OldColour Then
Cell.Interior.color = NewColour
End if
Next Cell
Next Sheet
You only need to Set object variables in VBA, your if statement is also problematic. Try:
For Each Sheet In ThisWorkbook.Worksheets
For Each Cell In Rng.Cells
If ActiveCell.DisplayFormat.Interior.color = OldColour Then
ActiveCell.DisplayFormat.Interior.color = NewColour
End if
Next Cell
Next Sheet

Replace cell fill color based on existing cell fill color in a column

I have attached screenshot to visualize what I am trying to do.
I am trying to replace the fill colors of cells in a column "Yesterday" based on the existing cell fill color.
I have seen examples of replacing colors based of a value in a cell but I think I have a different scenario.
maybe this can help you:
Option Explicit
Public Sub main()
Dim cell As Range, foundCells As Range
Dim yesterdayColor As Long, todayColor As Long
yesterdayColor = Range("H3").Interior.Color
todayColor = Range("H4").Interior.Color
With Range("B5:B17") '<--| reference wanted range of which coloring any "yesterdayColor" colored cells with "todayColor" color
Set foundCells = .Offset(, .Columns.Count).Resize(1, 1) '<-- initialize a dummy "found" cell outside the relevant range and avoid 'IF' checking in subsequent 'Union()' method calls
For Each cell In .Cells '<--| loop through referenced range cells
If cell.Interior.Color = yesterdayColor Then Set foundCells = Union(foundCells, cell) '<--| gather yesterday colored cells together
Next cell
Set foundCells = Intersect(.Cells, foundCells) '<--| get rid of the dummy "found" cell
End With
If Not foundCells Is Nothing Then foundCells.Interior.Color = todayColor '<--| if any cell has been found then change their color
End Sub
Edit: Try this.
Public Sub ChangeCellColors()
Dim rngTarget As Excel.Range: Set rngTarget = Range("H3")
Dim rngSource As Excel.Range: Set rngSource = Range("H4")
Dim rngCell As Excel.Range
For Each rngCell In Range("B4:B17")
With rngCell.Interior
If rngCell.Interior.Color = rngTarget.Interior.Color Then
.Pattern = rngSource.Interior.Pattern
.PatternColorIndex = rngSource.Interior.PatternColorIndex
.Color = rngSource.Interior.Color
.TintAndShade = rngSource.Interior.TintAndShade
.PatternTintAndShade = rngSource.Interior.PatternTintAndShade
End If
End With
Next rngCell
Set rngSource = Nothing
Set rngTarget = Nothing
Set rngCell = Nothing
End Sub

Resources