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
Related
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
I have VBA code that goes through a a range and changes the color of cells according to a predefined condition. The code works for two rows (rows 3 and 4) however, I want to use it another 98 Times.
Dim rCell As Excel.Range
Dim rRng As Range
Set rCell = Range("AS3")
For Each rCell In ws1.Range("AS3:BG3")
If rCell.Value < Range("BP3").Value Or rCell.Value > Range("BO3").Value Then
rCell.Select
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
End If
Next rCell
Set rCell = Range("AS4")
For Each rCell In ws1.Range("AS4:BG4")
If rCell.Value < Range("BP4").Value Or rCell.Value > Range("BO4").Value Then
rCell.Select
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
End If
Next rCell
If I understand correctly you want range("AS3:BG101") and the IF statement to reference the current rcell row. This should do it. I also removed your extraneous range setting and declaration as well as the selections.
Dim rCell As Range
For Each rCell In ws1.Range("AS3:BG101") 'Larger range
If rCell.Value < Range("BP" & rcell.row).Value Or rCell.Value > Range("BO" & rcell.row).Value Then 'Variable value
With rcell.Font 'No need to select
.Color = -16776961
.TintAndShade = 0
End With
End If
Next rCell
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?
In this code I am trying to have the user select a range in a row. If the row contains "HOL" the message box show will show a message.
The way the code is right now when the user chooses one cell that contains "HOL" the message appears when the user chooses multi cells in a row an error Runtime error 13 appears. This is the if statement that I am having problems
I have tried different range select methods but I am not familiar enough with coding yet to understand my error.
' Highlight_SKL Macro
' This macro will highlight leave dates for entry
Dim rng As Range
Set rng = Range(Selection.Address)
If MsgBox("Are you sure you want to submit day of SKL", vbYesNo) = vbNo Then Exit Sub
If InStr(Range(Selection.Address), "HOL") Then MsgBox ("You are entering a SKL date on a Federal Holiday")
With Selection.Interior
rng = "=1"
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 250
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End Sub
When the user select a row that contains "HOL" a message box appears and lets them know.
Use a wildcard MATCH for a selection of one or many cells.
If Not IsError(application.match("*HOL*", Selection, 0)) Then _
MsgBox "You are entering a SKL date on a Federal Holiday"
The below code use for each loop to loop each cell of the selection to avoid errors.
Option Explicit
Sub test()
Dim rng As Range, cell As Range
Set rng = ThisWorkbook.Worksheets("Sheet1").Range(Selection.Address) '<- Change sheet name if need
If MsgBox("Are you sure you want to submit day of SKL", vbYesNo) = vbNo Then Exit Sub
For Each cell In rng
If InStr(cell, "HOL") Then MsgBox ("You are entering a SKL date on a Federal Holiday")
With cell
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 250
.TintAndShade = 0
.PatternTintAndShade = 0
End With
.Value = 1
End With
Next cell
End Sub
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