I have a spreadsheet where i implement a score board.
The behavior i need is when the cell that has the score value rises the cell near it, on column b, changes it's color to green, when the the cell score value goes down the cell near it changes it's color to red.
The cell range where the score is changing is e5:e67
In short:
When the user inputs a number in column f, the score raises in column e, and in column b (on same row) the color must change to green or red
I made this VBA code, but without luck.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("e5:e67")) Is Nothing Then
If Target.Column = 5 Then
thisRow = Target.Row
Dim OldValue As Variant
Application.EnableEvents = False
Application.Undo
OldValue = Target.Value
Application.Undo
Application.EnableEvents = True
If OldValue < Target.Value Then
Range("b" & thisRow).Interior.ColorIndex = 4
ElseIf OldValue > Target.Value Then
Range("b" & thisRow).Interior.ColorIndex = 3
End If
End If
End If
End Sub
Here is a screen capture of my ranking sheet:
Try by intercepting the Worksheet_Calculate event. You need to save the old value in a static local array, that I call oldVal.
Private Sub Worksheet_Calculate()
Static oldVal
If IsEmpty(oldVal) Then
oldVal = Application.Transpose(Range("e5:e67").Value2)
ReDim Preserve oldVal(5 To 67)
Exit Sub
End If
Dim i As Long
For i = LBound(oldVal) To UBound(oldVal)
If oldVal(i) > Cells(i, "E").Value2 Then Cells(i, "B").Interior.ColorIndex = 3
If oldVal(i) < Cells(i, "E").Value2 Then Cells(i, "B").Interior.ColorIndex = 4
oldVal(i) = Cells(i, "E").Value2
Next
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
If Not Intersect(Target, Range("e6:e67")) Is Nothing Then
If Target.Offset(-1) < Target Then
i = 4
Else
i = 3
End If
Range("b" & Target.Row).Interior.ColorIndex = i
End If
End Sub
Related
I am attempting to get my code to work when multiple cells are selected/changed. I'm not too sure where to go from here as I'm having trouble setting a variable to a target when the target is a multi-cell selection.
An example of what I need would be: All cells in column 1 are selected and deleted, so subsequently I want all cells in column 2 to also be deleted. Instead the code returns an error and does not delete column 2 for any of the selected rows.
Here is the code:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Application.ScreenUpdating = False
If Target.Column = 1 Then
Application.EnableEvents = False
Dim OldValue As String
Dim NewValue As String
NewValue = Target.Value
Application.Undo
OldValue = Target.Value
Target.Value = NewValue
Application.EnableEvents = True
If OldValue = "" Then
Exit Sub
Else
Application.EnableEvents = False
Target.Offset(0, 1).ClearContents
MsgBox "Contents related to this drop-down have been cleared"
End If
End If
Exithandling:
Application.EnableEvents = True
Exit Sub
Application.ScreenUpdating = True
End Sub
Something like this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, oldVal, newVal, i As Long, num As Long, c As Range
On Error GoTo haveError:
'only process the part of Target which overlaps with ColA...
Set rng = Application.Intersect(Target, Me.Columns(1))
'run some checks before proceeding...
If rng Is Nothing Then Exit Sub
If rng.Cells.Count = Me.Columns(1).Cells.Count Then Exit Sub 'ignore full-column operations
If rng.Areas.Count > 1 Then Exit Sub 'handling multiple areas will be more complex...
If Application.CountBlank(rng) = 0 Then Exit Sub 'no empty cells: nothing to do here
Application.EnableEvents = False
newVal = GetArray(rng)
Application.Undo
oldVal = GetArray(rng)
rng.Value = newVal
For Each c In rng.Cells
i = i + 1
If newVal(i, 1) = "" And oldVal(i, 1) <> "" Then
c.Offset(0, 1).ClearContents
num = num + 1
End If
Next c
If num > 0 Then MsgBox "Contents related to drop-down(s) have been cleared"
haveError:
If Err <> 0 Then Debug.Print Err.Description
Application.EnableEvents = True
End Sub
'normalizes the array vs. scalar returned when calling .Value
' on a multi- vs. single-cell range
Function GetArray(rng As Range)
Dim arr
If rng.Count > 1 Then
arr = rng.Value
Else
ReDim arr(1 To 1, 1 To 1)
arr(1, 1) = rng.Value
End If
GetArray = arr
End Function
I'm trying to get a piece of code that, when a cell in column 8 changes it deletes the value of cell next to it(column 9).
Well... That is the simple version
Column 8 and 9 are both dropdown lists, the dropdown list in column 9 is dependent on column 8. In column 9, multiple answers are necesary so i found a code on the internet that made that possible, but now the value in column 9 doesn't delete automatically when i change the value in column 8.
This piece of code below works, but only when i change 1 cell(in column 8) at the time. It doesn't work when i paste multiple Cells in Column 8 or when i select a cell in column 8 and then drag it down(from the lower right corner).
I don't have a lot of experience with coding and just can't seem to find the right solution for this.
Thanks to QHarr i got a bit further.
This is my second attempt:
Dim ClearC9 As String
Dim i As Long
For i = 2 To 1000
If Target.Cells.Count > 1 Then GoTo ClearC9
If Not Intersect(Target, Range("H" & i)) Is Nothing Then
Range("I" & i).ClearContents
End If
Next i
exitHandler:
Application.EnableEvents = True
Columns("I:I").EntireColumn.AutoFit
ClearC9:
Selection.Offset(, 1).ClearContents
First Attempt:
Dim i As Long
For i = 2 To 1000
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("H" & i)) Is Nothing Then
Range("I" & i).ClearContents
End If
This is the entire code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim lUsed As Long
If Target.Count > 1 Then GoTo exitHandler
On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler
If rngDV Is Nothing Then GoTo exitHandler
If Intersect(Target, rngDV) Is Nothing Then
'do nothing
Else
Application.EnableEvents = False
newVal = Target.Value
Application.Undo
oldVal = Target.Value
Target.Value = newVal
If Target.Column = 9 Then
If oldVal = "" Then
'do nothing
Else
If newVal = "" Then
'do nothing
Else
lUsed = InStr(1, oldVal, newVal)
If lUsed > 0 Then
If Right(oldVal, Len(newVal)) = newVal Then
Target.Value = Left(oldVal, Len(oldVal) - Len(newVal) - 2)
Else
Target.Value = Replace(oldVal, newVal & ", ", "")
End If
Else
Target.Value = oldVal _
& ", " & newVal
End If
End If
End If
End If
End If
Dim i As Long
For i = 2 To 1000
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("H" & i)) Is Nothing Then
Range("I" & i).ClearContents
End If
Next i
exitHandler:
Application.EnableEvents = True
Columns("I:I").EntireColumn.AutoFit
End Sub
The general pattern to to create an intersection range:
if it is Nothing then do nothing
otherwise loop over its cells
for example:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range, TheIntersection As Range, r As Range
' stuff
TheIntersection = Intersect(Target, rngDV)
If TheIntersection Is Nothing Then
' do nothing
Else
For Each r In TheIntersection
' do something
Next r
End If
End Sub
I need to change a value of a cell. For example, Range("B1").value is "Cake" and i do
Range("B1").value = "Bubblegum"
But, I have a Worksheet_Change event and when it starts, if I MsgBox "Target.value" it will be "Cake" and not "Bubblegum".
Here is my Event :
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cellAdress As String
cellAdress = Target.Column
If cellAdress = 5 Then
If Target.Value = "X" Then
Range("F" & Target.Row).Value = "0,0€"
ElseIf Target.Value = "O" Then
If Range("A" & Target.Row).Interior.ColorIndex = 2 Then
Range("F" & Target.Row).Value = Worksheets("Astreinte").Range("B10").Value
Else
Range("F" & Target.Row).Value = Worksheets("Astreinte").Range("B11").Value
End If
Else
Range("F" & Target.Row).Value = "Valeur Incorrecte"
End If
End If
End Sub
And Here is my code
For Each myDate In DateMonthCorrespondante
Range("E" & (2 + Day(myDate))).Value = "O"
Next
How can I change that?
Thanks for your help
You can try using the SelectionChange and Change events in tandem, viz
Dim v
Private Sub Worksheet_Change(ByVal Target As Range)
MsgBox v
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
v = Target.Value
End Sub
All this goes in the sheet module. Then you can add conditions to restrict the situations in which you want the box to appear and so on.
Disable the events before and re-enable after.
Application.EnableEvents = False
Range("B1").value = "Bubblegum"
Application.EnableEvents = True
Well, with your help i finally solved my problem.
I had an error in the line
Range("E" & (2 + Day(myDate))).Value = "O"
And because of the event, it didn't say it to me.
I am trying to auto-populate the next columns based on the selected dropdown option of the 1st column on excel.
Below sample of the initial code that I thought but it appears my approach is incorrect.
Private Sub WorksheetStore_Change(ByVal Target As Range)
Dim i As Integer
Dim intCol As Integer
intCol = shtStoreGroup.Range("A")
If Not IsEmpty(Target.value) And intCol > 1 And Target.Columns.Count = 1 And Target.Column = intCol And Target.Row > Start_Row Then
For i = Target.Row To Target.Row + Target.Rows.Count - 1
If shtStoreGroup.Columns(intCol).Rows(i).value = "Create" Then
shtStoreGroup.Columns(intCol + 2).Rows(i).value = "N/A"
shtStoreGroup.Columns(intCol + 3).Rows(i).value = "Test"
Next i
End If
End Sub
May be you're after this:
Private Sub Worksheet_Change(ByVal target As Range)
If Not ValidateTarget(target, 2) Then Exit Sub '<-- exit if function validating 'Target' returns 'False'
On Error GoTo EXITSUB ' <-- be sure to handle possible errors properly
Application.EnableEvents = False '<--| disable events handling not to run this sub on top of itself
Select Case UCase(target.Value)
Case "CREATE"
target.Offset(, 2).Value = "N/A"
target.Offset(, 3).Value = "Test"
Case "DELETE"
target.Offset(, 2).Value = "???"
target.Offset(, 3).Value = "Test??"
End Select
EXITSUB:
Application.EnableEvents = True '<--| restore events handling
End Sub
Function ValidateTarget(target As Range, Start_Row As Long) As Boolean
With target
If .columns.Count > 1 Then Exit Function
If .Column <> 1 Then Exit Function
If .Row <= Start_Row Then Exit Function
If IsEmpty(.Value) Then Exit Function
ValidateTarget = True
End With
End Function
place the above code in the relevant worksheet ("shtStoreGroup"?) code pane, and NOT in a normal module code pane
I don't think you need worksheet_change() function
with a combobox named cbTest I would do it like
Option Explicit
Sub fill()
cbTest.AddItem ("Value1")
cbTest.AddItem ("Value2")
End Sub
Private Sub cbTest_Change()
Select Case cbTest.Value
Case "Value1"
Cells(1, 1).Value = "Test"
Case "Value2"
Cells(1, 2).Value = "Test2"
End Select
End Sub
Currently working on an excel sheet to rank projects, we would like it to automatically increase the numbers if we insert a new line and input an existing number rank. If we put in a line and type in 9 for its rank we want the pre existing 9 to move to 10 and the old 10 to move to 11 etc. I have kind of worked it out, however my code automatically numbers the first row as 1 and so forth. This is what I have so far.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim I As Integer
I = 1
Application.EnableEvents = False
For I = 1 To 20
Range("A" & I).Value = I
Next
Range("A21").Value = ""
Application.EnableEvents = True
End Sub
You could loop through every cell in column A and, if its value is greater than (or equal to) the one just changed, increment it by one:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim I As Long
Dim v As Long
Dim r As Range
Set r = Application.Intersect(Range("A:A"), Target)
If r Is Nothing Then
Exit Sub
End If
If r.Count > 1 Then
Exit Sub
End If
If IsEmpty(r.Value) Then
Exit Sub
End If
I = 1
v = r.Value
If Application.CountIf(Range("A:A"), v) > 1 Then ' Only change things if this
' value exists elsewhere
Application.EnableEvents = False
For I = 1 To Cells(Rows.Count, "A").End(xlUp).Row
If Cells(I, "A").Address <> r.Address Then
If IsNumeric(Cells(I, "A").Value) Then ' skip cells that aren't numeric
If Cells(I, "A").Value >= v Then
Cells(I, "A").Value = Cells(I, "A").Value + 1
End If
End If
End If
Next
Application.EnableEvents = True
End If
End Sub