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
Related
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 have a VBA code for a Rota Sheet that is activated on change of any value in the row.
I want the code to be activated upon opening the excel.
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Set rng = Range("B2:V11")
If Not Intersect(Target, rng) Is Nothing Then
'scan each row (month)
Dim countRow As Long
Dim i As Long
For i = 1 To rng.Rows.count
If Not Intersect(Target, rng.Rows(i)) Is Nothing Then
If WorksheetFunction.CountIf(rng.Rows(i), "V") > 0 Then
countRow = 0
Dim cel As Range
For Each cel In rng.Rows(i).Cells
If cel.Value2 = "V" Then
countRow = countRow + 1
VacationChange cel, countRow
Else
VacationChange cel, 0
End If
Next cel
End If
End If
Next i
'scan each column (day)
Dim j As Long
For j = 1 To rng.Columns.count
If Not Intersect(Target, rng.Columns(j)) Is Nothing Then
If WorksheetFunction.CountIf(rng.Columns(j), "V") > 5 Then
VacationChange rng.Columns(j).Cells(0, 1), 6
Else
VacationChange rng.Columns(j).Cells(0, 1), 0
End If
End If
Next j
End If
End Sub
Private Function VacationChange(ByVal rng As Range, ByVal count As Long)
With rng.Interior
Select Case count
Case 0
'clear cell colors
.Pattern = xlNone
.Color = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
Case 1 To 3
'blue
.Pattern = xlSolid
.Color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
Case 4 To 5
'yellow
.Pattern = xlSolid
.ThemeColor = xlThemeColorAccent4
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
Case Else
'red
.Pattern = xlSolid
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End Select
End With
End Function
I spent efforts by trying:
1. Using below code in Workbook: which is throwing 424 error
Private Sub Workbook_Open()
Sheet1.Activate
Call Worksheet_Change(Target)
End Sub
Pasting the entire code under Workbook_Open() function which is not working
Can anyone suggest what i am missing in the code ?
Sample Output image is attached
enter image description here
The problem is that Target is an undeclared Variant in your Workbook_Open implementation. That means when it gets passed as a parameter that needs to be a Range, the implicit cast fails and results in an error 424 (Object required).
If you want to "simulate" every cell in your target range changing, you can simply loop over B2:V11 and pass it each individual cell (untested with your data, but should give the gist):
Private Sub Workbook_Open()
Sheet1.Activate
Dim cell As Range
For Each cell In Sheet1.Range("B2:V11")
'Worksheet_Change needs to be Public
Sheet1.Worksheet_Change cell
Next
End Sub
Note that this is by no means the ideal solution to what you are trying to do and is a sign that you need to refactor your code a little bit to extract the functionality that you currently have in Worksheet_Change into a free-standing procedure. If you need to run the same code from the Worksheet_Change handler, you can call that procedure.
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
Last week, I found an excellent code that I've been looking for. Except that I would like to use conditional formatting vertical, not horizontal as in the original code.
The orginal code is found from: Excel VBA - How do I select a range corresponding to values in previous cells?
I tried to modify the code to suit me, but there is still something wrong and I don't know what.
There is my code:
Sub tee()
Dim startRow As Long
Dim endRow As Long
Dim i As Long
Dim j As Long
Dim ws As Excel.Worksheet
Dim entryTime As Single
Dim exitTime As Single
Dim formatRange As Excel.Range
Set ws = ActiveSheet
startRow = ws.Range("19:19").Row
endRow = ws.Range("56:56").Row
Call clearFormats
For i = 3 To ws.Cells(1, 1).End(xlToRight).Column
entryTime = ws.Cells(15, i).Value
exitTime = ws.Cells(16, i).Value
Set formatRange = Nothing
For j = startRow To endRow
If (ws.Cells(j, 2).Value > exitTime) Then
Exit For
End If
If ((entryTime < ws.Cells(j, 2).Value) And (ws.Cells(j, 2).Value < exitTime)) Then
If (formatRange Is Nothing) Then
Set formatRange = ws.Cells(j, i)
Else
Set formatRange = formatRange.Resize(, formatRange.Rows.Count + 1)
End If
End If
Next j
If (Not formatRange Is Nothing) Then
Call formatTheRange(formatRange, ws.Cells(j, "A").Value)
End If
Next i
End Sub
Private Sub clearFormats()
With ActiveSheet.Range("C19:AA56")
.clearFormats
.ClearContents
End With
End Sub
Private Sub formatTheRange(ByRef r As Excel.Range, ByRef callsign As String)
r.HorizontalAlignment = xlCenter
r.Merge
r.Value = callsign
' Apply color
With r.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.Color = 3
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
' Apply borders
With r.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With r.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With r.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With r.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End Sub
The last two is ordinary code. I have change only the first one.
I don't have a lot of programming with VBA, but I'm trying hard.
Jukkis
The picture tells a thousand words! Here is some code that works. I have simplified your code considerably, rather than trying to learn what you did (and why it didn't work). Feel free to compare with your original, and figure out why one works when the other didn't.
Note - I use the MATCH function to find the rows where you start/end, then format the entire column in a single step. Since I made a smaller sheet, some of the row/column numbers are different - it should be easy to see where you have to change things in the code to work for you.
Option Explicit
Sub makeTimeGraph()
Dim startRow As Long
Dim endRow As Long
Dim entryTimeRow As Long
Dim entryTimeFirstCol As Long
Dim ws As Excel.Worksheet
Dim timeRange As Range
Dim c
Dim timeCols As Range
Dim entryTime
Dim exitTime
Dim formatRange As Excel.Range
Dim eps
eps = 1e-06 ' a very small number - to take care of rounding errors in lookup
' change these lines to match the layout of the spreadsheet
' first cell of time entries is B1 in this case:
entryTimeRow = 1
entryTimeFirstCol = 2
' time slots are in column A, starting in cell A3:
Set timeRange = Range("A3", [A3].End(xlDown))
' columns in which times were entered:
Set ws = ActiveSheet
Set timeCols = Range("B1:H1) ' select all the columns you want here, but only one row
' clear previous formatting
Range("B3", ws.Cells.SpecialCells(xlCellTypeLastCell)).clearFormats
' loop over each of the columns:
For Each c In timeCols.Cells
If IsEmpty(c) Then Goto nextColumn
entryTime = c.Value
exitTime = c.Offset(1, 0).Value
startRow = Application.WorksheetFunction.Match(entryTime + eps, timeRange) + timeRange.Cells(1.1).Row - 1
endRow = Application.WorksheetFunction.Match(exitTime - eps, timeRange) + timeRange.Cells(1.1).Row - 1
Set formatRange = Range(ws.Cells(startRow, c.Column), ws.Cells(endRow, c.Column))
Call formatTheRange(formatRange)
nextColumn:
Next c
End Sub
Private Sub formatTheRange(ByRef r As Excel.Range)
r.HorizontalAlignment = xlCenter
r.Merge
' Apply color
With r.Interior
.Pattern = xlSolid
.Color = 3
.TintAndShade = 0.8
End With
End Sub
Here is the result:
I have a very large set of data that includes start and stop times for aircraft in the NAS. I want to create a macro to make a visual representation of this data in excel, like the following:
(note: this image uses fake data)
As you can see I've done the first 7 rows by hand, but there are several data files with as many as 2500+ rows each which makes the process tedious. I've tried to create a macro but I'm confused how to search for and select the appropriate range to highlight.
Here's what I have so far:
Sub autofill()
Dim rng As Range
Dim row As Range
Dim cell As Range
'set the range of the whole search area
Set rng = Range("A2:HJ121")
For Each row In rng.Rows
Dim callsign As Variant
Set callsign = cell("contents", "A" & row)
Dim valstart As Variant
Set valstart = cell("contents", "E" & row)
Dim valstop As Variant
Set valstop = cell("contents", "F" & row)
'now select the range beginning from the column whose header matches the
'time in valstart and ends at the time which matches the time in valstop
Selection.Merge
Selection.Style = "Highlight"
Selection.Value = callsign
Next row
End Sub
What's the easiest way of selecting the rows I need?
I'm not a programmer by profession; apologies in advance if my code demonstrates sloppy technique or violates some holy programming principles. :P
Thanks!
Here's my go at VBA for this.
Option Explicit
Public Sub fillSchedule()
Dim startCol As Long
Dim endCol As Long
Dim i As Long
Dim j As Long
Dim ws As Excel.Worksheet
Dim entryTime As Single
Dim exitTime As Single
Dim formatRange As Excel.Range
Set ws = ActiveSheet
startCol = ws.Range("H:H").Column
endCol = ws.Range("HJ:HJ").Column
Call clearFormats
For i = 2 To ws.Cells(1, 1).End(xlDown).Row
entryTime = ws.Cells(i, 5).Value
exitTime = ws.Cells(i, 6).Value
Set formatRange = Nothing
For j = startCol To endCol
If (ws.Cells(1, j).Value > exitTime) Then
Exit For
End If
If ((entryTime < ws.Cells(1, j).Value) And (ws.Cells(1, j).Value < exitTime)) Then
If (formatRange Is Nothing) Then
Set formatRange = ws.Cells(i, j)
Else
Set formatRange = formatRange.Resize(, formatRange.Columns.Count + 1)
End If
End If
Next j
If (Not formatRange Is Nothing) Then
Call formatTheRange(formatRange, ws.Cells(i, "A").Value)
End If
Next i
End Sub
Private Sub clearFormats()
With ActiveSheet.Range("H2:HJ121")
.clearFormats
.ClearContents
End With
End Sub
Private Sub formatTheRange(ByRef r As Excel.Range, ByRef callsign As String)
r.HorizontalAlignment = xlCenter
r.Merge
r.Value = callsign
' Apply color
With r.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
' Apply borders
With r.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With r.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With r.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With r.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End Sub
How about a conditional formatting solution?
Highlight all the cells from H2 to (last bottom right cell).
Use this formula:
=IF(AND((H$1>$E2),(H$1<$F2)),TRUE)
Then apply a fill. And if you're willing to give up the border and the name inside the filled range, it will work for you :).
Also, you may want to Freeze Panes from G2 so you can scroll all the way to the HJ column and still see the Callsign column.
Hope this helps