In the table in the indicated range, I would like to mark the cell with the value in white, and the other cells with no value in gray. I have code but it doesn't produce any result. There is no error either. What to change to make it work
For Each cell In wbMe.Sheets("page3").Range("B76:K89")
If cell.Value = "Yes" Then cell.Interior.ColorIndex = 10
If cell.Value = "No" Then cell.Interior.ColorIndex = 3
Next cell
Please, run the next code. It will automatically place conditional formatting in the range you need:
Sub makeCondFormatting()
Dim sh As Worksheet, rng As Range, cond1 As FormatCondition, cond2 As FormatCondition
Set sh = ActiveSheet
Set rng = sh.Range("B76:K89")
With rng
.FormatConditions.Delete
Set cond1 = .FormatConditions.Add(xlExpression, Formula1:="=" & rng.cells(1, 1).Address(0, 0) & " <> """"")
Set cond2 = .FormatConditions.Add(xlExpression, Formula1:="=" & rng.cells(1, 1).Address(0, 0) & " = """"")
End With
With cond1
.Interior.color = RGB(255, 255, 255)
End With
With cond2
.Interior.color = RGB(197, 198, 198)
End With
End Sub
It will make the range cells change their interior color automatically when the cell is empty, or not.
try this code
Sub SetColor()
Dim r As Range
Set r = ThisWorkbook.ActiveSheet.Range("B2:B7")
Dim white As Long
white = RGB(255, 255, 255)
Dim grey As Long
grey = RGB(200, 200, 200)
Dim c As Range
For Each c In r
If c.Value2 = 1 Then c.Interior.Color = white
If c.Value2 = 0 Then c.Interior.Color = grey
Next
End Sub
As Ike mentions for Empty values you can use this
Sub SetColor()
Dim r As Range
Set r = ThisWorkbook.ActiveSheet.Range("B2:B7")
Dim white As Long
white = RGB(255, 255, 255)
Dim grey As Long
grey = RGB(200, 200, 200)
Dim c As Range
For Each c In r
If IsEmpty(c.Value2) Then
c.Interior.Color = white
'OR
'c.Interior.Pattern = xlNone
Else
c.Interior.Color = grey
End If
Next
End Sub
Related
I'm trying to apply some conditionals rules using VBA in a Range.
But I'm very new with conditional formating VBA so I'm a bit lost.
My Users can add rows above of the target range, that mean the range address could be always different.
let's admit that for the exemple, my range is Worksheets("test").Range("MyBoard")
("MyBoard" is my range name, currently located at A19:O32)
How can I apply a rule to turn yellow each rows of my range if the first column contains the value "Customer" ?
Sub FormatRange()
Dim MyRange As Range
Set MyRange = Worksheets("test").Range("MyBoard")
MyRange.FormatConditions.Delete
MyRange.FormatConditions.Add Type:=xlCellValue, Formula1:="=COUNTIF(MyRange;"*Customer*") > 0"
MyRange.FormatConditions(1).Interior.Color = RGB(255, 255, 0)
End Sub
Thanks for the help
Please, use the next adapted code:
Sub FormatRange()
Dim MyRange As Range, listSep As String
Set MyRange = Range("MyBoard")
listSep = Application.International(xlListSeparator)
MyRange.FormatConditions.Delete
MyRange.FormatConditions.Add Type:=xlExpression, formula1:="=ISNUMBER(SEARCH(" & _
"""Customer""" & listSep & MyRange.cells(1, 1).Address(0, 1) & "))"
MyRange.FormatConditions(1).Interior.Color = RGB(255, 255, 0)
End Sub
Conditional formatting has some very particular format to get an entire row to work.
E.g., If i want to apply a color to each row, between certain columns of a specified range:
With .Range(.Cells(1, startColumn), .Cells(lastRow, endColumn))
.FormatConditions.Add Type:=xlExpression, Formula1:="=$A1>1"
.FormatConditions(1).Font.Italic = True
End With
Edit1: Indicating use of Find() for the row containing "Customer" being used for the above code.
Sub test()
With Sheets(1)
Dim customerCell As Range: Set customerCell = .Columns(1).Find("Customer")
If customerCell Is Nothing Then Exit Sub
Dim lastRow As Long: lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Cells.FormatConditions.Delete
With .Range(.Cells(customerCell.Row, 1), .Cells(lastRow, 10))
.FormatConditions.Add Type:=xlExpression, Formula1:="=CountIf($A" & customerCell.Row & ",""*Customer*"")"
.FormatConditions(1).Interior.Color = RGB(255, 255, 0)
End With
End With
End Sub
I think, this is what your are looking for:
Sub FormatRange()
Dim MyRange As Range
Set MyRange = Worksheets("test").Range("MyBoard")
Dim startAddress As String
startAddress = MyRange.Cells(1, 1).Address(False, True) ' will return e.g. $A19 in your case
Dim formula As String
'formula = startAddress & " = ""customer""" 'exact customer
formula = "ISNUMBER(FIND(""customer""," & startAddress & "))" ' *customer*
Dim fc As FormatCondition
With MyRange
.FormatConditions.Delete
Set fc = .FormatConditions.Add(xlExpression, Formula1:="=" & formula)
fc.Interior.Color = RGB(255, 255, 0)
End With
End Sub
You have to reference the first cell within your range - and "fix" the column --> .Address(False, True) will return $A19 in your case.
Then you need to build a valid string for the formula to pass to the format condition
You need double quotes for "customer" when building the string.
I'm brand new to VBA and this is my first VBA script, it seems good enough, but it's made my spreadsheet really slow, I can do something to optimize it.
The script runs through some defined columns and checks for content "A" "S" and so on, and if the content matches, the script must color the cell a specific color and also the cell on the right
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim My_Range As Range
Set My_Range = Worksheets("Sæson").Range("J10:J40,Q10:Q39,X10:X40,AE10:AE39,AL10:AL40,AS10:AS40,AZ10:AZ39,BG10:BG40,BN10:BN39,BU10:BU40,CB10:CB40,CI10:CI38,CP10:CP40")
For Each cell In My_Range
If cell.Value = "S" Then
cell.Interior.Color = RGB(0, 255, 255)
cell.Offset(0, 1).Interior.Color = RGB(0, 255, 255)
ElseIf cell.Value = "FE" Then
cell.Interior.Color = RGB(255, 192, 0)
cell.Offset(0, 1).Interior.Color = RGB(255, 192, 0)
ElseIf cell.Value = "SF" Then
cell.Interior.Color = RGB(255, 192, 0)
cell.Offset(0, 1).Interior.Color = RGB(255, 192, 0)
ElseIf cell.Value = "T" Then
cell.Interior.Color = RGB(49, 255, 33)
cell.Offset(0, 1).Interior.Color = RGB(49, 255, 33)
ElseIf cell.Value = "TK" Then
cell.Interior.Color = RGB(0, 176, 240)
cell.Offset(0, 1).Interior.Color = RGB(0, 176, 240)
ElseIf cell.Value = "TH" Then
cell.Interior.Color = RGB(255, 153, 204)
cell.Offset(0, 1).Interior.Color = RGB(255, 153, 204)
ElseIf cell.Value = "SY" Then
cell.Interior.Color = RGB(255, 0, 0)
cell.Offset(0, 1).Interior.Color = RGB(255, 0, 0)
Else
cell.Interior.Color = xlNone
cell.Offset(0, 1).Interior.Color = xlNone
End If
Next
End Sub
As first option, you can also try to disable the ScreenUpdating option during the macro execution.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'variable declarations
'disable screen updating
Application.ScreenUpdating = False
'...
'code
'...
're-enable screen updating
Application.ScreenUpdating = True
End Sub
Apply Criteria Colors
It is assumed that the cells of the source range contain formulas. This will reapply colors to the whole range automatically (event-driven) each time the worksheet recalculates not necessarily meaning that a value in the range has changed (not quite efficient). It should be very fast on this small range though.
If the cells contain values then you can manually run applyCriteriaColors to get the desired result. Also, a solution would then be a different code written for the Worksheet_Change event (you cannot use this one).
Copy the codes to the appropriate modules.
Adjust the values in the constants section.
Standard Module e.g. Module1
Option Explicit
Sub applyCriteriaColors()
Const wsName As String = "Sheet1"
' The number of columns to apply the color to.
Const ColCount As Long = 2
' "cRangesList" has to contain a list of addresses of ONE-column ranges.
Const cRangesList As String = "J10:J40,Q10:Q39,X10:X40,AE10:AE39," _
& "AL10:AL40,AS10:AS40,AZ10:AZ39,BG10:BG40,BN10:BN39,BU10:BU40," _
& "CB10:CB40,CI10:CI38,CP10:CP40"
' "CriteriaList" and "CellColors" have to have the same number of elements.
' Note that "Ranges" has the same number of elements (ranges) as well.
Const CriteriaList As String = "S,FE,SF,T,TK,TH,SY"
Dim CellColors As Variant: CellColors = VBA.Array( _
16776960, 49407, 49407, 2228017, 15773696, 13408767, 255)
' Write values from Criteria List to Criteria Array.
Dim Criteria() As String: Criteria = Split(CriteriaList, ",")
' Calculate Ranges Count (not to be confused with "aCount").
Dim rCount As Long: rCount = UBound(Criteria) + 1
' Define Ranges Array.
Dim Ranges() As Range: ReDim Ranges(1 To rCount)
Dim wb As Workbook: Set wb = ThisWorkbook
' Define Source Range.
Dim srg As Range: Set srg = wb.Worksheets(wsName).Range(cRangesList)
' Calculate Source Range Areas Count, the number of elements in Data Array.
Dim aCount As Long: aCount = srg.Areas.Count
' Define Data Array (of Arrays).
Dim Data As Variant: ReDim Data(1 To aCount)
' Define One-Cell Array.
Dim OneCell As Variant: ReDim OneCell(1 To 1, 1 To 1)
Dim arg As Range ' Source Range Current Area
Dim cValue As Variant ' Current Value
Dim cMatch As Variant ' Current Match
Dim n As Long ' Source Range Areas Counter, Ranges Array Ranges Counter
Dim i As Long ' Current Array (of Data Array) Rows Counter
For n = 1 To aCount
' Write values from current area ('srg.Areas(n)') of Source Range
' ('srg') to current array ('Data(n)') of Data Array ('Data').
Set arg = srg.Areas(n) '.Columns(1) ' ... ONE-column ranges
If arg.Rows.Count > 1 Then
Data(n) = arg.Value
Else
Data(n) = OneCell: Data(1, 1) = arg.Value
End If
For i = 1 To UBound(Data(n), 1)
cValue = Data(n)(i, 1)
If Not IsError(cValue) Then
If Len(cValue) > 0 Then
' Attempt to find a match in Criteria Array.
cMatch = Application.Match(cValue, Criteria, 0)
If IsNumeric(cMatch) Then
' Combine matched cell resized by "ColCount"
' with 'associated' range in Ranges Array.
If Ranges(cMatch) Is Nothing Then
Set Ranges(cMatch) _
= arg.Cells(i).Resize(, ColCount)
Else
Set Ranges(cMatch) = Union(Ranges(cMatch), _
arg.Cells(i).Resize(, ColCount))
End If
End If
End If
End If
Next i
Next n
Application.ScreenUpdating = False
' Reset colors. Note that "Resize" doesn't work with multi-area ranges.
For n = 1 To aCount
srg.Areas(n).Resize(, ColCount).Interior.Color = xlNone
Next n
' Apply colors to the 'combined' ranges.
For n = 1 To rCount
If Not Ranges(n) Is Nothing Then
Ranges(n).Interior.Color = CellColors(n - 1)
End If
Next n
Application.ScreenUpdating = True
End Sub
Sheet Module e.g. Sheet1
Option Explicit
Private Sub Worksheet_Calculate()
applyCriteriaColors
End Sub
I've found this piece of code online and tried to modify it to do what i want. It works in a very basic way, where you assign it as a macro to a Form button, to find duplicates in 6 seperate columns, but is there a way of tidying up the code, and possibly automating it, so i don't have to press a form button to run the macro every time ?
Sub Check_Dups()
'Declaring variables
Dim Cell As Variant
Dim Source As Range
Dim Source2 As Range
Dim Source3 As Range
Dim Source4 As Range
Dim Source5 As Range
Dim Source6 As Range
'Initializing source range
Set Source = Range("E8:E105")
Set Source2 = Range("F8:F105")
Set Source3 = Range("G8:G105")
Set Source4 = Range("H8:H105")
Set Source5 = Range("I8:I105")
Set Source6 = Range("J8:J105")
'Removing any previous formatting from the source
Source.Interior.Color = RGB(255, 255, 255)
Source2.Interior.Color = RGB(255, 255, 255)
Source3.Interior.Color = RGB(255, 255, 255)
Source4.Interior.Color = RGB(255, 255, 255)
Source5.Interior.Color = RGB(255, 255, 255)
Source6.Interior.Color = RGB(255, 255, 255)
'Looping through each cell in the source range
For Each Cell In Source
'Checking whether value in cell already exist in the source range
If Application.WorksheetFunction.CountIf(Source, Cell) > 1 Then
'Highlighting duplicate values in red color
Cell.Interior.Color = RGB(255, 0, 0)
End If
Next
'Looping through each cell in the source range
For Each Cell In Source2
'Checking whether value in cell already exist in the source range
If Application.WorksheetFunction.CountIf(Source2, Cell) > 1 Then
'Highlighting duplicate values in red color
Cell.Interior.Color = RGB(255, 0, 0)
End If
Next
'Looping through each cell in the source range
For Each Cell In Source3
'Checking whether value in cell already exist in the source range
If Application.WorksheetFunction.CountIf(Source3, Cell) > 1 Then
'Highlighting duplicate values in red color
Cell.Interior.Color = RGB(255, 0, 0)
End If
Next
'Looping through each cell in the source range
For Each Cell In Source4
'Checking whether value in cell already exist in the source range
If Application.WorksheetFunction.CountIf(Source4, Cell) > 1 Then
'Highlighting duplicate values in red color
Cell.Interior.Color = RGB(255, 0, 0)
End If
Next
'Looping through each cell in the source range
For Each Cell In Source5
'Checking whether value in cell already exist in the source range
If Application.WorksheetFunction.CountIf(Source5, Cell) > 1 Then
'Highlighting duplicate values in red color
Cell.Interior.Color = RGB(255, 0, 0)
End If
Next
'Looping through each cell in the source range
For Each Cell In Source6
'Checking whether value in cell already exist in the source range
If Application.WorksheetFunction.CountIf(Source6, Cell) > 1 Then
'Highlighting duplicate values in red color
Cell.Interior.Color = RGB(255, 0, 0)
End If
Next
End Sub
Some other ways to automate a macro are WorkSheet_Change and Workbook_Open events, but I would stick with Button_Click to initiate your macro.
The below code can be use to loop through the range in each column and color duplicate values using AutoFilter. If you want to color each group a different color, you can use the randomized RGB line of code.
Sub ColorDuplicates_wRGB()
'This macro loops thru each cell, if the cell has duplicates in the range, it filters the range using the cell value,
'then colors the visible cells in the range Red or with a unique color using RGB Colors.
'xlNone in the If statement, skips previous colored cells.
'Works with both sorted and unsorted data.
Dim ws As Worksheet, rng As Range, cel As Range, colr As String, i As Long 'Define your variables
Application.ScreenUpdating = False 'I hate to see the screen flickering
Set ws = ThisWorkbook.Sheets("Sheet1") 'identify the worksheet variable; you will need to change the sheet reference
For i = 5 To 9 'To loop through each column
Set rng = ws.Range(ws.Cells(8, i), ws.Cells(105, i))
rng.Interior.ColorIndex = xlNone 'clear interior color for all cells in range
For Each cel In rng 'Loop
If WorksheetFunction.CountIf(rng, cel.Value) > 1 And cel.Interior.ColorIndex = xlNone Then
'Filter using cel.Value
rng.AutoFilter field:=1, Criteria1:=cel.Value
colr = RGB(255, 0, 0)
'If you want different colors for each duplicate group use the next line
'colr = RGB(Int((255 - 1 + 1) * Rnd() + 1), Int((255 - 1 + 1) * Rnd() + 1), Int((255 - 1 + 1) * Rnd() + 1))
'Select the visible cells in range and color, the -1 removes the blank row at the end caused by Offset
rng.Offset(1).Resize(rng.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Interior.Color = colr
rng.AutoFilter 'reset filter
End If
Next cel
Next i
Application.ScreenUpdating = True
End Sub
I recently started playing with VBA and I try al I could to figure it out but without the success.
Basically what I would like to do is to find a colour in the range and then if the cell is blank, I would like to put value 0 and keep the colour.
Below is the code I created but it is not working on "If PCell.Value = "" Then"
Sub ColorCell()
PCell = RGB(255, 204, 204)
range("A:F").Select
For Each cell In Selection
If cell.Interior.Color = PCell Then
If PCell.Value = "" Then
Set cell.Value = 0
End If
End If
Next
End Sub
Below is an example of how the spreadsheet.
I would really appreciate your help. I spent all day browsing and trying but no luck :(
Your code has some issues:
Set should be used only on objects (like Worksheets or Range)
you test PCell.Value instead of cell.Value
Here is the working code:
Sub ColorCell()
PCell = RGB(255, 204, 204)
Range("A:F").Select
For Each cell In Selection
If cell.Interior.Color = PCell Then
If cell.Value = "" Then
cell.Value = 0
End If
End If
Next
End Sub
You could try:
Option Explicit
Sub test()
Dim cell As Range, rng As Range
Dim LastRow As Long
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "F").End(xlUp).Row '<- Get the last row of column F to avoid looping all the column
Set rng = .Range("A1:F" & LastRow) '<- Set the range from A1 to F last row
For Each cell In rng
If cell.Interior.Color = RGB(255, 204, 204) And cell.Value = "" Then
cell.Value = 0
End If
Next cell
End With
End Sub
Replace:
If PCell.Value = "" Then
with:
If Cell.Value = "" Then
Replace:
Set cell.Value = 0
with:
cell.Value = 0
Also avoid Select:
Sub ColorCell()
Dim PCell As Variant, Intersection As Range, Cell As Range
PCell = RGB(255, 204, 204)
Set Intersection = Intersect(Range("A:F"), ActiveSheet.UsedRange)
If Not Intersection Is Nothing Then
For Each Cell In Intersection
If Cell.Interior.Color = PCell Then
If Cell.Value = "" Then
Cell.Value = 0
End If
End If
Next
End If
End Sub
(there may be other errors in the code)
PCell is not cell
Sub ColorCell()
PCell = RGB(255, 204, 204)
For Each cell In intersect(ActiveSheet.usedrange, range("A:F"))
If cell.Interior.Color = PCell and cell.Value = "" Then
cell.Value = 0
End If
Next
End Sub
The code I have below is checking two worksheets in order to see if the values inserted in the specific column are similar. For example, it looks to see if the values inserted in column A from sheet1 are the same as the values inserted in sheet2 column B. If yes, then the cells in sheet1 column A remain 'white' otherwise, they turn 'red'. The code works without any problems and really fast.
My problem is the following. Lets say:
I need to insert a value in sheet1 - Column A, cell A2 to A5 that match the ones from sheet2 Column B.
sheet2 column B has the following values: car, house, garden, city, country.
If in A2 I write car, A3 I leave empty, A4 country and A5 car, then A2, A4 and A5 will remain 'white' because those values are in sheet2 - Column B. However, A3 turns red even though the cell is empty - this my problem. How can I make the code to not take into consideration if that cell is empty? It should not turn red because I left the cell empty and it is not comparing anything...
I hope I explain myself somehow. Thanks for your help!
Private Sub CommandButton1_Click()
Set wb = Excel.ActiveWorkbook
Set aRec = wb.Worksheets(1)
Set bRec = wb.Worksheets(2)
Application.ScreenUpdating = False
For a = 2 To aRec.Cells(Rows.Count, "A").End(xlUp).Row
match = Application.match(aRec.Cells(c, 1).Value, bRec.Columns(2), 0)
If IsError(match) Then
aRec.Cells(c, 1).Interior.Color = RGB(255, 0, 0)
Else
aRec.Cells(c, 1).Interior.Color = RGB(255, 255, 255)
End If
Next c
End Sub
Like?
Private Sub CommandButton1_Click()
Set wb = Excel.ActiveWorkbook
Set aRec = wb.Worksheets(1)
Set bRec = wb.Worksheets(2)
Application.ScreenUpdating = False
For a = 2 To aRec.Cells(Rows.Count, "A").End(xlUp).Row
Match = Application.Match(aRec.Cells(a, 1).Value, bRec.Columns(2), 0)
If IsError(Match) And Not IsEmpty(aRec.Cells(a, 1)) Then
aRec.Cells(a, 1).Interior.Color = RGB(255, 0, 0)
Else
aRec.Cells(a, 1).Interior.Color = RGB(255, 255, 255)
End If
Next a
End Sub
With correct loop variable, Option Explicit, type declarations and switching screenupdating back on
Option Explicit
Private Sub CommandButton1_Click()
Dim wb As Workbook
Dim aRec As Worksheet
Dim bRec As Worksheet
Dim a As Long
Dim Match As Variant
Set wb = ActiveWorkbook
Set aRec = wb.Worksheets(1)
Set bRec = wb.Worksheets(2)
Application.ScreenUpdating = False
For a = 2 To aRec.Cells(Rows.Count, "A").End(xlUp).Row
Match = Application.Match(aRec.Cells(a, 1).Value, bRec.Columns(2), 0)
If IsError(Match) And Not IsEmpty(aRec.Cells(a, 1)) Then
aRec.Cells(a, 1).Interior.Color = RGB(255, 0, 0)
Else
aRec.Cells(a, 1).Interior.Color = RGB(255, 255, 255)
End If
Next a
Application.ScreenUpdating = True
End Sub