In my table I have the date in the format "dddd , mmmm dd, yyyy". So for example "Sunday ,July 05,2020". I want the macro to format cells that have the word "Sunday" in and can't get it to work. I can change it to the dd string (ie 17) or the yyyy string (ie 2020) and it works, but not the dddd or mmmm strings which contain text.
Sub colour()
Dim rng As range
Dim lastRow As Long
Dim cell As range
lastRow = Cells(Rows.Count, 3).End(xlUp).Row
Set rng = range("J2:J" & lastRow)
For Each cell In rng
'If I change "Sunday" to "17" for example, or "2020", the routine works, but I cannot get it to find
'the dddd string
If InStr(cell.Value, "Sunday") > 0 Then
range(cell.Address).Interior.ColorIndex = 19
Else
range(cell.Address).Interior.ColorIndex = 0
End If
Next cell
End Sub
Stephen,
You can do this directly on the sheet:
Or by code:
Option Explicit
Sub HighlightSundays()
Dim rng As Range
Set rng = Range("A1:A21")
With rng
.FormatConditions.Add Type:=xlExpression, _
Formula1:="=WEEKDAY(A1)=7"
.FormatConditions(.FormatConditions.Count).SetFirstPriority
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
End With
.FormatConditions(1).StopIfTrue = True
End With
End Sub
HTH
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 am looking to create a macro where it will prompt a user to enter a date and it will take that value and compare it to each date value in Column E.
It has already been presorted by date. I am just looking to have the macro insert One Orange line from Columns A-L after it finds the the last value where the row above it has an earlier date, and the row below it either has the same date or a date further out.
The file will vary from a few dozen lines to 2000+ and includes spaces in between rows.
I am working on my skillset for each component of the code but am having trouble piecing it all together.
Thanks in advance.
Sub datechecker()
Dim ddate As Date
Dim rCell As Range
Dim r As Long
If IsDate(Range("B:B")) Then
ddate = Application.InputBox(MsgGP, TitleMsg, FormatDateTime(Date, vbShortDate), Type:=1)
Else
MsgBox "Non valid date"
Exit Sub
End If
For Each rCell In .Range(.Cells(1, "E"), .Cells(.Rows.count, "E").End(xlUp))
If IsDate(rCell) Then
If rCell >= ddate Or rCell.Value = "" Then
rCell.Offset (-1)
Else
If ddate >= rCell Then
rCell.Row.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 49407
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
End If
Next rCell
End Sub
I'm trying to highlight cells that have a date greater than today's date.
Column H is formatted as Date.
I have the following:
Sub Test()
Dim lrow As Long
lrow = Cells(Rows.Count, 1).End(xlUp).Row
Columns("H:H").EntireColumn.AutoFit
If Range("H2:H" & lrow).Value > Date Then Cell.Interior.Color = vbYellow
End Sub
I get a "Type Mismatch" error.
Range("H2:H" & lrow).Value will be a 2D array (the Value of a Range is always a 2D array if more than a single cell is involved); you're getting a type mismatch error because you can't compare a 2D array to a Date; if you can't use a conditional formatting, you need to compare the individual array subscripts.
Last thing you want to do is to iterate each individual cells (otherwise your next question will be "how do I make this loop run faster?"). Get that array into a Variant, and iterate that array - since it's only 1 column, make it a 1D array with Application.Transpose:
Dim values As Variant
values = Application.Transpose(Range("H2:H" & lastRow).Value)
Dim i As Long, current As Long
For i = LBound(values) To UBound(values)
current = i + 1 'array would be 1-based, so to start at row 2 we need to offset by 1
If values(i) > Date Then
ActiveSheet.Cells(current, 8).Interior.Color = vbYellow
End If
Next
That way you only hit the worksheet when you have to.
In response to #MatthieuGuindon's suggestion to #CharlesPL's answer, here's some code that does the conditional formatting. I've set it so it highlights dates that are after the day you run it as a bright yellow.
Option Explicit
Sub setCondFormat()
Dim lrow As Long
lrow = ActiveSheet.Range("H" & ActiveSheet.Rows.Count).End(xlUp).Row
With Range("H2:H" & lrow)
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=H2>TODAY()"
With .FormatConditions(.FormatConditions.Count)
.SetFirstPriority
With .Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
End With
End With
End With
End Sub
Use conditional formatting! As the name suggests, this is build for that!
Microsoft blog post on date conditional formating
I would recommend iterating over the range of cells and testing each cell individually. Please see below.
Dim rng As Range, cell As Range
Set rng = Range("H:H")
For Each cell In rng
If cell.Value > Date Then cell.Interior.Color = vbYellow
Next cell
I have a hierarchy codification system within a sheet column. I would like looking for values within that column that match in partially way with values on that column also. The search should start from longer values. Here the sample:
AME_ASO_010_010_010
AME_ASO_010_010_010_010 (longer values, search starting)
In summary i look for some ideas for finding matches, without taking into account last four places (_010).
Thanks to all!
Any support will be appreciated!
With the contribution of dwirony, im trying this. Would somebody please know why is giving me object required error (424). Many thanks!
it Fails in line > Left(cell, Len(cell) - 4).Offset(, 1).Select
Sub main()
Dim cell As Range
Dim arr As Variant, arrElem1 As Variant
Dim rng As Range
Dim sh1 As Worksheet
Set sh1 = Sheets("Valeurs")
With Worksheets("Valeurs")
For Each cell In .Range("E1", .Cells(.Rows.Count, "E").End(xlUp))
Set rng = Range(cell, cell.Offset(0, 12))
arr = Split(Replace(cell.Value, " ", " "), " ")
For Each arrElem1 In arr
If Len(arrElem1) = 15 Then
Left(cell, Len(cell) - 4).Offset(, 1).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent4
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
End If
Next arrElem1
Next cell
End With
End Sub
Trying and trying the success has arrived!
Here the code, maybe it will be useful for others.
Subject closed!
Sub main()
Dim i As Long
Dim cell As Range
Dim lResult As String
Dim arr As Variant, arrElem1 As Variant
Dim rng As Range, rng1 As Range
Dim sh1 As Worksheet
With Worksheets("Valeurs")
For Each cell In .Range("E1", .Cells(.Rows.Count, "E").End(xlUp))
arr = Split(Replace(cell.Value, " ", " "), " ")
For Each arrElem1 In arr
If Len(arrElem1) = 15 Then
lResult = Left(arrElem1, Len(arrElem1) - 4)
Set rng1 = sh1.Range("E15:E10000")
Set Findv = Range("E15:E10000").Cells.Find(What:=lResult, LookAt:=xlWhole, _
After:=Range("E15"), SearchDirection:=xlPrevious)
Findv.Offset(0, 1).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent4
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
End If
Next arrElem1
Next cell
End With
End Sub
enter image description hereI have today's data in column D which I want to compare with yesterday's data in column F, row wise.
Below is the code I'm using to compare and highlight duplicates.
A) Highlighting blank cells which I don't want.
B) I want to handle some exceptions like I don't wish to highlight $0.00 or specific text "No Data"
Sub CompareAndHighlight()
Dim Myrng1 As Range, Myrng2 As Range, i As Long, j As Long
Application.ScreenUpdating = False
For i = 3 To Sheets("Sheet1").Range("D" & Rows.Count).End(xlUp).Row
Set Myrng1 = Sheets("Sheet1").Range("D" & i)
For j = 3 To Sheets("Sheet1").Range("F" & Rows.Count).End(xlUp).Row
Set Myrng2 = Sheets("Sheet1").Range("F" & j)
If StrComp(Trim(Myrng1.Text), Trim(Myrng2.Text), vbTextCompare) = 0 Then
'If Myrng1.Value = Myrng2.Value Then
Myrng1.Interior.Color = RGB(255, 255, 0)
End If
Set Myrng2 = Nothing
Next j
Set Myrng1 = Nothing
Next i
Application.ScreenUpdating = True
End Sub
Data giving random errors on running macros multiple times after clearing highlighted colors.
Use the conditional formatting function.
Columns("A:A").Select
Selection.FormatConditions.AddUniqueValues
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).DupeUnique = xlDuplicate
With Selection.FormatConditions(1).Font
.Color = -16383844
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13551615
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Then after this create one loop that goes through your range and turns the colour of the cell to no colour where your conditions are met, alternatively you could just filter the data to exclude your cases, such as "No Data", and copy and paste the results into a new column. In fact you do not really need vba for this.
sticking with VBA you could try the following code:
Option Explicit
Sub CompareAndHighlight()
Dim refRng As Range, cell As Range
Application.ScreenUpdating = False
With Worksheets("Sheet1")
Set refRng = .Range("F3", .Cells(.Rows.Count, "F").End(xlUp)).SpecialCells(XlCellType.xlCellTypeConstants)
For Each cell In .Range("D3", .Cells(.Rows.Count, "D").End(xlUp)).SpecialCells(XlCellType.xlCellTypeConstants)
If cell.value <> 0 And cell.value <> "No Data" Then
If refRng.Find(what:=cell.value, LookIn:=xlFormulas, lookat:=xlWhole, MatchCase:=False) Is Nothing Then cell.Interior.color = RGB(255, 255, 0)
End If
Next cell
End With
Application.ScreenUpdating = True
End Sub