My code currently colors values in Range("N2:N86") anytime I insert a value in that range. However, I want to add an additional line of code that colors or highlights the preceding column Range("M2:M86") whenever a value is entered in Range("N2:N86").
So for example, if i put the value of 1 in N2, I want both N2 and M2 to be highlighted red. Thanks
Dim rCell As Range
Dim inRng As Range
Dim rRng As Range
Set myRng = Range("N2:N86")
myRng.Locked = True
If Range("R4") < 0 Then
For Each rCell In myRng
If rCell.Value > 0 Then
If rRng Is Nothing Then
Set rRng = rCell
Else
Set rRng = Application.Union(rRng, rCell)
End If
End If
Next
rRng.Locked = False
rRng.Interior.ColorIndex = 3
End If
I'm not 100% sure on what you are asking for, but here's something that you can test. (Colors rows in both columns upon change in cell value in N column)
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Intersect(Range("N2:N86"), Target) Is Nothing Then
Target.Interior.ColorIndex = 36
Target.Offset(, -1).Interior.ColorIndex = 36
End If
Application.EnableEvents = True
End Sub
Related
Private Sub Worksheet_Change(ByVal Target As Range)
StartRow = 21
EndRow = 118
ColNum = 1
For i = StartRow To EndRow
If Cells(i, ColNum).Value = Range("A4").Value Then
Cells(i, ColNum).EntireRow.Hidden = True
Else
Cells(i, ColNum).EntireRow.Hidden = False
End If
Next i
End Sub
The Range I want to dictate when the code is run is D21:D118. It will start out blank and then have data pulled into it
Thank you!
It's quite difficult and error-prone to tell in a Change event handler what the previous cell value was before it was edited. You might consider narrowing the logic so it only runs if a cell in A21:A118 is changed.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, c As Range, vA4
'Does Target intersect with our range of interest?
Set rng = Application.Intersect(Target, Me.Range("A21:A118"))
If rng Is Nothing Then Exit Sub 'no change in monitored range
vA4 = Me.Range("A4").Value
For Each c In rng.Cells 'loop over updated cells
c.EntireRow.Hidden = (c.Value = vA4) 'check each updated cell value
Next c
End Sub
I would like to apply vba formula to designated cells. The vba I am working on would be: If I type something on C2, a date stamp will be automatically put in D2.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 3 Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
With Target.Offset(0, 1)
.Value = Now
.NumberFormat = "MM/DD/YYYY"
End With
End Sub
However, if I typed something on C1, a date stamp will appear as well. How can I limit the range of the vba? For example, I just want the date stamp from D2 to D5.
Thanks!!
You can apply Intersect function to check if target falls into the desired range, like this
Dim dr As Range
Set dr = Range("C2:C5")
If Not Intersect(target, dr) Is Nothing Then
... it is OK, go ahead
EndIf
The first answer is right, however here is the full version of it
Paste this in the Project of the table, not as a VBA module
Private Sub Worksheet_Change(ByVal Target As Range)
Dim WorkRng As Range
Dim rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("C2:C5"), Target)
xOffsetColumn = 1
If Not WorkRng Is Nothing Then
Application.EnableEvents = False
For Each rng In WorkRng
If Not VBA.IsEmpty(rng.Value) Then
rng.Offset(0, xOffsetColumn).Value = Now
rng.Offset(0, xOffsetColumn).NumberFormat = "mm-dd-yyyy"
Else
rng.Offset(0, xOffsetColumn).ClearContents
End If
Next
Application.EnableEvents = True
End If
End Sub
I have a big table (100 columns * 1000 rows) and certain cells in this table are filled with different colors (red, yellow, blue, orange and other colors). I want to clear all selected cells that have no colors. I wrote a simple macro that will be good for a small table, but for a large table, the computational power drops and if several colored cells are selected in the same range, then the cells are not cleared. How can I reduce the cleaning time of the table and fix the error when the specified area has different colors?
Sub ClearData()
For Each cell in Selection
If cell.Interior.ColorIndex = xlNone Then
cell.ClearContents
End If
Next cell
MsgBox "Done!"
End Subs
Sub ClearData()
Dim Cell As Range
Dim URng As Range
For Each Cell In Selection
If Cell.Interior.ColorIndex = xlNone Then GoSub UnionRange
Next
If Not URng Is Nothing Then URng.ClearContents: MsgBox "Done!"
Exit Sub
UnionRange:
If Not URng Is Nothing Then
Set URng = Union(URng, Cell)
Else
Set URng = Cell
End If
Return
End Sub
Try this code
Sub ClearData()
Dim c As Range, r As Range
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Sheet1")
For Each c In .Range("A1").CurrentRegion
If c.Interior.ColorIndex = xlNone Then
If r Is Nothing Then Set r = c Else Set r = Union(r, c)
End If
Next c
If Not r Is Nothing Then r.Cells.Clear
End With
Application.ScreenUpdating = True
MsgBox "Done...", 64
End Sub
I am trying to write a code for Excel in VBA which looks at a range of cells, in this example Range B4:B15, and first identifies which cells have a yellow fill color (interior color). Then of the cells colored yellow determine if any of those cells are blank.
If any of the yellow cells are blank, give a message for the entire range saying "there are yellow cells that are blank".
I'm using a For each rcell in r loop to determine which cells are yellow colored.
How do I build a new "sub-range" with only the cells colored yellow?
Sub Input_Checker_test()
Dim ws As Worksheet
Set ws = Sheets("Main")
Dim r As Range
Dim rcell As Range
Dim rmain As Range
Dim rmaincell As Range
Set r = Range("B4:B15").Cells
For Each rcell In r
If rcell.Interior.Color = 65535 Then
rcell = rmain
End If
Next rcell
For Each rmaincell In rmain
If WorksheetFunction.CountA(rmain) = 0 Then
MsgBox ("Cells are empty")
Else
MsgBox ("Cells are full")
End If
Next rmaincell
End Sub
I'm a little confused because you said font, then interior. If there is a yellow font, then there has to be a value, so I assumed you meant interior. Since you only need one of each to meet your criteria, you don't need to create a sub-range. You can test to see if any cells meet both criteria.
Sub Input_Checker_test()
Dim ws As Worksheet
Set ws = Sheets("Main")
Dim r As Range
Dim rcell As Range
Dim YellowCount as Integer
Dim EmptyCount as Integer
Set r = ws.Range("B4:B15")
For Each rcell In r
If rcell.Interior.Color = 65535 Then
YellowCount = 1
If IsEmpty(rcell) Then
EmptyCount = 1
End If
End If
Next rcell
If YellowCount > 0 Then
MsgBox "There are yellow cells"
End If
If EmptyCount > 0 Then
MsgBox "There are empty cells"
End If
End Sub
I'm currently working on a calendar where some days (each separate cells) have green, blue and others red backgrounds
I would like to be able to click one cell in the given range (one day in the calendar). If that cell has a specific background color, I would like all other cells in that range that are the same color to change and the text to be bold.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
Dim cell As Range
Dim Rng As Range
Set Rng = ActiveWorkbook.Sheets("Tickets").Range("N11:AW20")
For Each cell In Rng
If Target.Interior.ColorIndex = 37 Then
Target.Font.Bold = True
End If
Exit For
Next cell
End Sub
So far the text of the Target cell changes to bold but not the rest of the cells in that range.
How can I get excel to scan the rest of the range and apply the changes?
PS: Originally I would have preferred triggering the macro when hovering over the cells but I couldn't find anything to do so.
Here is the file with the calendar to give you a better idea of the whole thing.
https://drive.google.com/file/d/17tveiFHu4nlw47jqmXixIQoe6j7iOTe-/view?usp=sharing
Thanks in advance!
If you put this code into the module for the sheet with the calendar, it should activate each cell in the calendar range that has the same background color as the current selection.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rngCalendar As Range
Set rngCalendar = Range("N11:AW20")
If Not Intersect(Target, rngCalendar) Is Nothing Then
SpeedUp True
rngCalendar.Font.Bold = False
Dim cel As Range
For Each cel In rngCalendar
If cel.Interior.ColorIndex = Target.Interior.ColorIndex Then
cel.Font.Bold = True
End If
Next cel
SpeedUp False
End If
End Sub
Private Function SpeedUp(ByVal toggleOn As Boolean)
With Application
.Calculation = IIf(toggleOn, xlCalculationManual, xlCalculationAutomatic)
.ScreenUpdating = Not toggleOn
.EnableEvents = Not toggleOn
End With
End Function
The problem is that your loop doesn't actually do anything to the cell it's in.
You could change it into something like this
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
Dim cell As Range
Dim Rng As Range
Set Rng = ActiveWorkbook.Sheets("Tickets").Range("N11:AW20")
If target.Interior.Colorindex = 37 then
For Each cell In Rng
If cell.Interior.ColorIndex = 37 Then
cell.Font.Bold = True
End If
Next cell
End if
End Sub
I think it should help :)
Dim cell As Range
Dim Rng As Range
Dim status As Integer
Set Rng = ActiveWorkbook.Sheets("Tickets").Range("N11:AW20")
For Each cell In Rng
If Target.Interior.ColorIndex = 37 Then
Target.Font.Bold = True
status = 1
Exit For
End If
Next cell
If status = 1 Then
Rng.Interior.ColorIndex = 37
Rng.Font.Bold = True
End If