Click one cell and change all cells of the same color - excel

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

Related

Target.Adress = Range

how can I make a Target.Adress from 1 cell to a range of cells?
If Target.Address = "$G$7" And WorksheetFunction.IsNumber(Target) Then Target = -Abs(Target)
End Sub
Changing G7 to G7:G49
I tried different examples like
If Target.Address = "(G7:G49)" And WorksheetFunction.IsNumber(Target) Then Target = -Abs(Target)
End Sub
and others... but it didnĀ“t work.
Instead of using .Address, use Intersect.
Loop over the cells in the Intersection.
Assuming this is within a Worksheet_Change handler, disable events to prevent an infinite loop, and enable at the end.
Dim rng As Range
Set rng = Intersect(Target, Me.Range("G7:G49"))
If rng Is Nothing Then Exit Sub
On Error GoTo SafeExit
Application.EnableEvents = False
Dim cell As Range
For Each cell In rng
If WorksheetFunction.IsNumber(cell.Value) Then
cell.Value = -Abs(cell.Value)
End If
Next
SafeExit:
Application.EnableEvents = True

Conditional hiding worksheet from multiple selections

I need a sheet in Excel to activate if any cells in a column are selected as "Yes", but my VBA code won't stick - simple enough to do for one cell, but the whole column is throwing me. The cells are a drop down list with solely the options "Yes" or "No"
Currently trying:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$H$11:$H$23" Then
If ActiveWorkbook.Worksheets("Sheet1").Range("H11:H23").Value = "Yes" Then
Sheets("Sheet2").Visible = True
Else
Sheets("Sheet2").Visible = False
End If
End If
End Sub
Any tips? Thanks
An easier solution without looping would be to count the Yes using WorksheetFunction.CountIf method.
Use the following to show Sheet2 if at least one cell has the Yes.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim TestRange As Range
Set TestRange = Me.Range("H11:H23")
If Not Application.Intersect(Target, TestRange) Is Nothing Then 'if target is in test range
If Application.WorksheetFunction.CountIf(TestRange, "Yes") > 0 Then
Worksheets("Sheet2").Visible = True
Else
Worksheets("Sheet2").Visible = False
End If
End If
End Sub
If all cells in the test range need to be Yes then change it to
If Application.WorksheetFunction.CountIf(TestRange, "Yes") = TestRange.Cells.Count Then
i think you could try:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range, rng As Range
Dim Inrng As Boolean
If Not Intersect(Target, Me.Range("H11:H23")) Is Nothing Then
'Set a boolean variable to false
Inrng = False
'Set a range to loop
Set rng = Me.Range("H11:H23")
'Start looping the range
For Each cell In rng
'Convert the value of a cell to Upper case to avoid case sensitive issues
If UCase(cell.Value) = "YES" Then
'Turn the variable to true if value appears in the range
Inrng = True
'Exit the loop to avoid time consuming
Exit For
End If
Next cell
If Inrng = True Then
Worksheets("Sheet2").Visible = True
Else
Worksheets("Sheet2").Visible = False
End If
End If
End Sub

Color Two Cells Excel VBA

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

How to show value in cell depending on its filled color - event in Excel VBA

In Excel I would like to show value in current cell depending on its filled color ( something like IFCOLOR() ). Excel should do this automatically when I change filled color therefore it should be event.
For example:
When I fill cell in green then Excel automatically shows value 100
When I fill cell in red then automatically Excel shows value 75
and so on ...
Is it possible do this by event in Excel VBA? Or can you give me other ideas how to do it?
I used Workbook_SheetChange but this works when I change value in cell not its background color.
Regards
Jan
You can try something like this:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If ActiveCell.Interior.Color = vbRed Then
ActiveCell = 75
Else
ActiveCell = " "
End If
End Sub
With a predefind range:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim rng As Range, cell As Range
Set rng = ws.Range(Cells(1, 1), Cells(100, 20))
For Each cell In rng
If cell.Interior.Color = RGB(255, 0, 0) Then
cell = 75
ElseIf cell.Interior.Color = RGB(0, 255, 0) Then
cell = 100
Else
cell = " "
End If
Next cell
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
CommandBars.OnUpdate can be used to handle most custom events. In the ThisWorkbook object:
Private WithEvents bars As CommandBars, color As Double
Private Sub bars_OnUpdate()
'If Not ActiveSheet Is Sheet1 Then Exit Sub ' optional to ignore other sheets
If ActiveCell.Interior.color = color Then Exit Sub ' optional to ignore if same color
color = Selection.Interior.color
'Debug.Print Selection.Address(0, 0), Hex(color)
If color = vbGreen Then Selection = 100 Else _
If color = vbRed Then Selection = 75
End Sub
Private Sub Workbook_Activate()
Set bars = Application.CommandBars ' to set the bars_OnUpdate event hook
End Sub
Private Sub Workbook_Deactivate()
Set bars = Nothing ' optional to unset the bars_OnUpdate event hook
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
color = Selection.Interior.color ' optional to ignore selection change events
End Sub
The above sample doesn't handle all edge cases, but can be adjust as needed.
For other custom events, the more specific CommandBarControl events should be used if possible:
CommandBarButton.Click
CommandBarComboBox.Change
CommandBarControl.OnAction
CommandBarPopup.OnAction

Macro that automatically formats cell when value is entered. (convert macro to the event macro?)

I've got a spreadsheet, where I'd like A:A range to be formatted automatically so that characters will show in red and digits stay the same color. The following macro seems to work OK, but I need to manually run it every time I change value in the cell:
Sub Red_text()
Dim i As Integer
Dim MyString As String
MyString = ActiveCell.Value
For i = 1 To Len(MyString)
If IsNumeric(Mid(MyString, i, 1)) = False Then
ActiveCell.Characters(i, 1).Font.Color = RGB(247, 66, 66)
End If
Next i
End Sub
So basically I need to change it into an event macro that will reformat the current cell every time it is edited. And limit this behavior to A:A range.
Any help would be greatly appreciated!!
First a slight change to your macro:
Sub Red_text(r As Range)
Dim i As Integer
Dim MyString As String
MyString = r.Value
For i = 1 To Len(MyString)
If IsNumeric(Mid(MyString, i, 1)) = False Then
r.Characters(i, 1).Font.Color = RGB(247, 66, 66)
End If
Next i
End Sub
and also include the following event macro in the worksheet code area:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range
Set A = Range("A:A")
If Intersect(A, Target) Is Nothing Then Exit Sub
Application.EnableEvents = False
Call Red_text(Target)
Application.EnableEvents = True
End Sub
The event macro detects entries to column A and then applies formatting.
EDIT#1:
The event macro must change to handle more than one cell at a time. Remove the original event macro and use this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range, rBIG As Range, r As Range
Set A = Range("A:A")
Set rBIG = Intersect(A, Target)
If rBIG Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In rBIG
Call Red_text(r)
Next r
Application.EnableEvents = True
End Sub

Resources