I need to program a conditional format in Excel VBA (2016) without using the existing conditional formatting tool. As I am a newbie and tried for a while the following, I'm asking you to help me.
I want to write this e.g. in a private sub: for range E18:G18 and K1:K10:
If value is >=1 then colour = green
If value is <1 or "" then colour red
for range B1:B10
If value is >=3 then colour = green
If value is <3 & >0 then colour yellow
if value is 0 or "" the colour red
My code is the following - when i save it, nothing happens in my second defined range (K1:K10), also after reopening the excel-workbook.
Also nothing happens with my second conditional formatting range (B1:B10):
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngObserve As Range, rngCell As Range
Set rngObserve = Intersect(Target, Range("E18:G18, K1:K10"))
If rngObserve Is Nothing Then
Exit Sub
End If
For Each rngCell In rngObserve.Cells
If Not Intersect(rngCell, rngObserve) Is Nothing Then
If rngCell.Value = vbNullString Then
rngCell.Interior.Color = xlNone
ElseIf rngCell.Value < 1 Then
rngCell.Interior.ColorIndex = 3 'red
ElseIf rngCell.Value >= 1 Then
rngCell.Interior.ColorIndex = 4 'green
Else
rngCell.Interior.ColorIndex = 3 'red
End If
End If
Next
Dim rngObserve As Range, rngCell As Range
Set rngObserve = Intersect(Target, Range("B1:B10"))
If rngObserve Is Nothing Then
Exit Sub
End If
For Each rngCell In rngObserve.Cells
If Not Intersect(rngCell, rngObserve) Is Nothing Then
If rngCell.Value = vbNullString Then
rngCell.Interior.Color = xlNone
ElseIf rngCell.Value < 3 And rgncell.Value > 0 Then
rngCell.Interior.ColorIndex = 6 'yellow
ElseIf rngCell.Value >= 3 Then
rngCell.Interior.ColorIndex = 4 'green
Else
rngCell.Interior.ColorIndex = 3 'red
End If
End If
Next
End Sub
As mentioned in the comments, you can only have one Worksheet_Change subroutine. This code should get you what you need:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngObserve As Range, rngCell As Range
'PGCodeRider comment: I'd set these to named ranges instead of hard-coded addresses
Set rngObserve = Intersect(Target, Range("E18:G18, K1:K10"))
If Not rngObserve Is Nothing Then
For Each rngCell In rngObserve.Cells
If rngCell.Value = vbNullString Then
rngCell.Interior.Color = xlNone
ElseIf rngCell.Value < 1 Then
rngCell.Interior.ColorIndex = 3 'red
ElseIf rngCell.Value >= 1 Then
rngCell.Interior.ColorIndex = 4 'green
Else
rngCell.Interior.ColorIndex = 3 'red
End If
Next rngCell
End If
Set rngObserve = Intersect(Target, Range("B1:B10"))
If Not rngObserve Is Nothing Then
For Each rngCell In rngObserve.Cells
If rngCell.Value = vbNullString Then
rngCell.Interior.Color = xlNone
ElseIf rngCell.Value < 3 And rngCell.Value > 0 Then
rngCell.Interior.ColorIndex = 6 'yellow
ElseIf rngCell.Value >= 3 Then
rngCell.Interior.ColorIndex = 4 'green
Else
rngCell.Interior.ColorIndex = 3 'red
End If
Next rngCell
End If
End Sub
Related
I'm using Worksheet_Change to make a value (either 1 or 0) appear in the next cell (Bx) when a value is entered in a range of cells (A1:A10).
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
If Target.Value = 1 Then
Target.Offset(0, 1).Value = 1
Else:
Target.Offset(0, 1).Value = 0
End If
End If
End Sub
The problem occurs when I try to clear the cells in column A.
When I select the cells I want to clear and press "Delete" I get "Run-time error '13' - Type mismatch" on the line "IF Target.Value = 1".
I would also like the cells in the B column to be cleared if I clear cells in the A column. E.g. if I delete cell A2:A5, B2:B5 should be cleared.
From what I understand the problem is that when selecting multiple cells it returns an array as the Target, and this is a mismatch with the Integer.
Is there a way around this problem?
Try this. You need to cater for multiple cells in some way, for the reasons you mention, and add an extra clause to your If.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, r1 As Range
Set r = Intersect(Target, Range("A1:A10"))
If Not r Is Nothing Then
For Each r1 In r
If r1.Value = 1 Then
r1.Offset(0, 1).Value = 1
ElseIf r1.Value = vbNullString Then
r1.Offset(0, 1).Value = vbNullString
Else
r1.Offset(0, 1).Value = 0
End If
Next r1
End If
End Sub
In a first step we add the functionality that multiple cells are selected and changed:
Private Sub Worksheet_Change_Var1(ByVal Target As Range)
Dim targetCell As Range
'If Target.Range.count
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
If Target.Cells.Count > 1 Then
For Each targetCell In Target
If targetCell.Value = 1 Then
targetCell.Offset(0, 1).Value = 1
Else
targetCell.Offset(0, 1).Value = 0
End If
Next targetCell
Else
If Target.Value = 1 Then
Target.Offset(0, 1).Value = 1
Else
Target.Offset(0, 1).Value = 0
End If
End If
End If
End Sub
In the 2nd step we understand that also the "one cell" case can be handled in the same way and we add an if clause for the "cell(s) cleared" case:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim targetCell As Range
'If Target.Range.count
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
For Each targetCell In Target
If targetCell.Value = 1 Then
targetCell.Offset(0, 1).Value = 1
Else
targetCell.Offset(0, 1).Value = 0
End If
'if cell in col A is empty, then clear cell in col B
If targetCell.Value = "" Then targetCell.Offset(0, 1).ClearContents
Next targetCell
End If
End Sub
I am currently running the code below:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
Worksheet_SelectionChange Target
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With Target
If Intersect(.Cells, Range("E4:K120")) Is Nothing Or .Count > 1 Then Exit Sub
Select Case .Value
Case ""
.Interior.ColorIndex = 3
Case 1
.Interior.ColorIndex = xlNone
.Value = vbNullString
Exit Sub
Case Else
Exit Sub
End Select
.Value = .Value + 1
End With
End Sub
I now need to run a similar code for a different cell range on the same worksheet. I need the code to cycle through 4 different colours and text when cells within the N column are clicked. I am not a coder so this is way above my paygrade. Thanks!
Maybe something like this:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Set a flag to let us know if we're in that "one color" range or "four color" range
Dim GroupIndicator As Integer
GroupIndicator = 0
With Target
'if our selection has more than one cell, just don't do anything (exit the sub)
If .Count > 1 Then
Exit Sub
End If
'if our selection is in the first range, set our indicator to 1. if it's in the second range, set the indicator to 2
If Not Intersect(.Cells, Range("E4:K120")) Is Nothing Then
GroupIndicator = 1
ElseIf Not Intersect(.Cells, Range("N4:N120")) Is Nothing Then
GroupIndicator = 2
Else
Exit Sub
End If
'do this block if indicator is 1 (the first range). If there's no value, make the cell red and put in a value of 1. Otherwise, clear the color and remove the value
If GroupIndicator = 1 Then
If .Value = "" Then
.Interior.ColorIndex = 3
.Value = 1
Else
.Interior.ColorIndex = xlNone
.Value = vbNullString
End If
End If
'do this block if indicator is 2 (the second range). increment our value and then assign the value indicated.
If GroupIndicator = 2 Then
.Value = .Value + 1
Select Case .Value
Case 1
.Interior.ColorIndex = 5
Case 2
.Interior.ColorIndex = 6
Case 3
.Interior.ColorIndex = 7
Case 4
.Interior.ColorIndex = 8
Case Else
.Interior.ColorIndex = xlNone
.Value = vbNullString
End Select
End If
End With
End Sub
I'd like to change Color Cell when I select it. I use this function but I can't back the original color of the Cell.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static rngcolor As Range
If Not rngcolor Is Nothing Then rngcolor.Interior.ColorIndex = xlNone
Set rngcolor = Target
rngcolor.Interior.Color = vbYellow
End Sub
You need to store the original Color as well as the cell reference. Also, the user might select more than one cell, each of which may have its own color.
Here's a starting point to deal with these complexities. Note that this accounts for the user selecting a contiguous range of >= 1 cells. They may also select a non-contiguous mutli cell range. A second more complex version provides for this
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static rngcolor As Range
Static OldColor As Variant
Dim rw As Long, cl As Long
If Not rngcolor Is Nothing Then
If IsArray(OldColor) Then
On Error GoTo NoRestore
For rw = 1 To rngcolor.Rows.Count
For cl = 1 To rngcolor.Columns.Count
If IsEmpty(OldColor(rw, cl)) Then
rngcolor.Cells(rw, cl).Interior.ColorIndex = xlNone
Else
rngcolor.Cells(rw, cl).Interior.Color = OldColor(rw, cl)
End If
Next
Next
On Error GoTo 0
Else
If IsEmpty(OldColor) Then
rngcolor.Interior.ColorIndex = xlNone
Else
rngcolor.Interior.Color = OldColor
End If
End If
End If
NoRestore:
On Error GoTo 0
Set rngcolor = Target
ReDim OldColor(1 To Target.Rows.Count, 1 To Target.Columns.Count)
For rw = 1 To Target.Rows.Count
For cl = 1 To Target.Columns.Count
If Target.Cells(rw, cl).Interior.ColorIndex = xlNone Then
OldColor(rw, cl) = Empty
Else
OldColor(rw, cl) = Target.Cells(rw, cl).Interior.Color
End If
Next
Next
rngcolor.Interior.Color = vbYellow
End Sub
Version to account for a non-contiguous range selection
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static rngcolor As Range
Static OldColor As Variant
Dim OldColrRng As Variant
Dim ar As Long, rw As Long, cl As Long
If Not rngcolor Is Nothing Then
If IsArray(OldColor) Then
On Error GoTo NoRestore
For ar = 1 To rngcolor.Areas.Count
For rw = 1 To rngcolor.Areas(ar).Rows.Count
For cl = 1 To rngcolor.Areas(ar).Columns.Count
If IsEmpty(OldColor(ar)(rw, cl)) Then
rngcolor.Areas(ar).Cells(rw, cl).Interior.ColorIndex = xlNone
Else
rngcolor.Areas(ar).Cells(rw, cl).Interior.Color = OldColor(ar)(rw, cl)
End If
Next
Next
Next
On Error GoTo 0
Else
If IsEmpty(OldColor) Then
rngcolor.Interior.ColorIndex = xlNone
Else
rngcolor.Interior.Color = OldColor
End If
End If
End If
NoRestore:
On Error GoTo 0
Set rngcolor = Target
ReDim OldColor(1 To Target.Areas.Count)
For ar = 1 To Target.Areas.Count
ReDim OldColrRng(1 To Target.Areas(ar).Rows.Count, 1 To Target.Areas(ar).Columns.Count)
OldColor(ar) = OldColrRng
Next
For ar = 1 To Target.Areas.Count
For rw = 1 To Target.Areas(ar).Rows.Count
For cl = 1 To Target.Areas(ar).Columns.Count
If Target.Areas(ar).Cells(rw, cl).Interior.ColorIndex = xlNone Then
OldColor(ar)(rw, cl) = Empty
Else
OldColor(ar)(rw, cl) = Target.Areas(ar).Cells(rw, cl).Interior.Color
End If
Next
Next
Next
rngcolor.Interior.Color = vbYellow
End Sub
Note: Using Static (or global) variables is vulnerable to being stopped by an error, either in this code or other code. Depending on how important it is to restore the colors, you may want to store the Range reference and colors somewhere else: eg in cells on a (hidden) sheet, in (hidden) names, in a external repository (eg text or ini file, in the registary etc), or in an CustomXmlPart
To get this done with the original colour of the cell (as per comments) is a lot more complicated than you've done in your example (setting it back to xlnone). The following sub with accompanying function will do the trick for any RGB colour available.
Public rngcolor As Range
Public rngcolor2 As Variant
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not rngcolor Is Nothing Then
If Not rngcolor2 = "" Then
If rngcolor2 = 16777215 Then
rngcolor.Interior.ColorIndex = xlNone
Else
rngcolor.Interior.Color = rngcolor2
End If
End If
End If
Set rngcolor = Target
rngcolor2 = Color(Target)
rngcolor.Interior.Color = vbYellow
End Sub
The function getting the RGB colour form the cell: (source)
Function Color(rng As Range, Optional formatType As Integer = 0) As Variant
Dim colorVal As Variant
colorVal = Cells(rng.Row, rng.Column).Interior.Color
Select Case formatType
Case 1
Color = Hex(colorVal)
Case 2
Color = (colorVal Mod 256) & ", " & ((colorVal \ 256) Mod 256) & ", " & (colorVal \ 65536)
Case 3
Color = Cells(rng.Row, rng.Column).Interior.ColorIndex
Case Else
Color = colorVal
End Select
End Function
This stores the original cell and original colour as an RGB value in a public variable, and resets the deselected cell to these values.
Please note, if multiple cells are selected at once, their interior colour will be reset to that of the first cell in the selection.
Also note the value 16777215 is for RGB white, the default cell colour, equal to xlNone. If the exception for this is left out, the cell will be filled with white, instead of being reset to no colour. If you have cells specifically coloured white, omit this step.
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
I would like to use vba to carry out conditional formatting.
I want to format cell backround containing string Yes with green and red for string No. Earlier, I used a For loop but since the data is huge the algorithm takes a lot of time and excel becomes non responsive.
Then I tried to use Private Sub Worksheet_Change(ByVal Target As Range) to detect the change in cell and to apply colors to it but it does not work as it is supposed to.
This is what I have tried so far:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MyRange As Range
Dim KeyCells As Range
Set KeyCells = Range("A1:A10")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
Set MyRange = ActiveCell
MyRange.Select
If MyRange.Value = "Yes" Then
MyRange.Interior.ColorIndex = 35
MyRange.Font.ColorIndex = 50
ElseIf MyRange.Value = "No" Then
MyRange.Interior.ColorIndex = 22
MyRange.Font.ColorIndex = 9
Else
MyRange.Value = ""
MyRange.Interior.ColorIndex = xlNone
MyRange.Font.ColorIndex = 1
End If
End If
End Sub
In support of my comment, here is the fix
Private Sub Worksheet_Change(ByVal target As Range)
Dim KeyCells As Range
Set KeyCells = Range("A1:A10")
If Not Application.Intersect(KeyCells, Range(target.Address)) _
Is Nothing Then
If target.Value = "Yes" Then
target.Interior.ColorIndex = 35
target.Font.ColorIndex = 50
ElseIf target.Value = "No" Then
target.Interior.ColorIndex = 22
target.Font.ColorIndex = 9
Else
target.Value = ""
target.Interior.ColorIndex = xlNone
target.Font.ColorIndex = 1
End If
End If
End Sub
You need to be aware that a change can be made to more than one cell at once. E.g. If user pastes a value into a range - or selects a range and then deletes.
To work around this, you cycle through each cell in the changed area.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MyRange As Range
Dim KeyCells As Range
Set KeyCells = Range("A1:A10")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
Application.EnableEvents = False
For Each MyRange In Application.Intersect(KeyCells, Range(Target.Address)).Cells
If MyRange.Value = "Yes" Then
MyRange.Interior.ColorIndex = 35
MyRange.Font.ColorIndex = 50
ElseIf MyRange.Value = "No" Then
MyRange.Interior.ColorIndex = 22
MyRange.Font.ColorIndex = 9
Else
MyRange.Value = ""
MyRange.Interior.ColorIndex = xlNone
MyRange.Font.ColorIndex = 1
End If
Next
Application.EnableEvents = True
End If
End Sub
Testing:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MyRange As Range
Dim KeyCells As Range
Set KeyCells = Range("A1:A10")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
With Target
If .Value = "Yes" Then
.Interior.ColorIndex = 35
.Font.ColorIndex = 50
ElseIf .Value = "No" Then
.Interior.ColorIndex = 22
.Font.ColorIndex = 9
ElseIf .Value = "" Then
.Interior.ColorIndex = xlNone
.Font.ColorIndex = 1
End If
End With
End If
End Sub
If your cells to check will always be A1:A10, or some other range that will never change, then I agree that conditional formatting is the way to go. If you have several columns to check and they are not always static, then building a find function might be easier. Here is one that you can send a range to and the text you are searching for:
Sub testFindAndColor()
Dim bg1 As Long, bg2 As Long
Dim fg1 As Long, fg2 As Long
Dim myRange As Range
Dim stringToFind As String
bg1 = 50: bg2 = 9
fg1 = 35: fg2 = 22
Set myRange = ActiveSheet.Range("A1:A30")
stringToFind = "Yes"
Run findAndColorize(myRange, stringToFind, bg1, fg1)
Set myRange = Nothing
End Sub
Function findAndColorize(myRange As Range, textToSearchFor As String, backLongColor As Long, foreLongColor As Long)
Dim newRange As Range
With myRange
Set c = .Find(textToSearchFor, LookIn:=xlValues, MatchCase:=False)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.Interior.ColorIndex = backLongColor
c.Font.ColorIndex = foreLongColor
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
Set c = Nothing
End Function