I am currently running the code below:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
Worksheet_SelectionChange Target
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With Target
If Intersect(.Cells, Range("E4:K120")) Is Nothing Or .Count > 1 Then Exit Sub
Select Case .Value
Case ""
.Interior.ColorIndex = 3
Case 1
.Interior.ColorIndex = xlNone
.Value = vbNullString
Exit Sub
Case Else
Exit Sub
End Select
.Value = .Value + 1
End With
End Sub
I now need to run a similar code for a different cell range on the same worksheet. I need the code to cycle through 4 different colours and text when cells within the N column are clicked. I am not a coder so this is way above my paygrade. Thanks!
Maybe something like this:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Set a flag to let us know if we're in that "one color" range or "four color" range
Dim GroupIndicator As Integer
GroupIndicator = 0
With Target
'if our selection has more than one cell, just don't do anything (exit the sub)
If .Count > 1 Then
Exit Sub
End If
'if our selection is in the first range, set our indicator to 1. if it's in the second range, set the indicator to 2
If Not Intersect(.Cells, Range("E4:K120")) Is Nothing Then
GroupIndicator = 1
ElseIf Not Intersect(.Cells, Range("N4:N120")) Is Nothing Then
GroupIndicator = 2
Else
Exit Sub
End If
'do this block if indicator is 1 (the first range). If there's no value, make the cell red and put in a value of 1. Otherwise, clear the color and remove the value
If GroupIndicator = 1 Then
If .Value = "" Then
.Interior.ColorIndex = 3
.Value = 1
Else
.Interior.ColorIndex = xlNone
.Value = vbNullString
End If
End If
'do this block if indicator is 2 (the second range). increment our value and then assign the value indicated.
If GroupIndicator = 2 Then
.Value = .Value + 1
Select Case .Value
Case 1
.Interior.ColorIndex = 5
Case 2
.Interior.ColorIndex = 6
Case 3
.Interior.ColorIndex = 7
Case 4
.Interior.ColorIndex = 8
Case Else
.Interior.ColorIndex = xlNone
.Value = vbNullString
End Select
End If
End With
End Sub
Related
I need help with Excel VBA code.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 And Target.Cells.Count = 1 Then
If LCase(Target.Value) = "-1" Then
With Target.EntireRow.ClearContents
End With
End If
End If
If Target.Column = 3 And Target.Cells.Count = 1 Then
If LCase(Target.Value) = "1000" Then
With Target.EntireRow
.Copy Sheets("Week Schedule").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Delete
End With
End If
End If
End Sub
If the third column we enter -1 it will clear the row. If we enter 1000 it will be copied to another sheet and deleted from the current sheet.
The above code is working fine. Instead of clearing row data, I want to delete that row.
So added
Line 4 With Target.EntireRow.ClearContents to With Target.EntireRow.Delete
But it shows an error.
It would help to know what error you get. Assuming the error is caused because the Week Schedule sheet does not exist, you can add a check for that. After that, your code works fine:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 And Target.Cells.Count = 1 Then
If LCase(Target.Value) = "-1" Then
With Target.EntireRow.ClearContents
End With
End If
End If
If Target.Column = 3 And Target.Cells.Count = 1 Then
If LCase(Target.Value) = "1000" Then
With Target.EntireRow
SheetExistsOrCreate ("Week Schedule")
.Copy Sheets("Week Schedule").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Delete
End With
End If
End If
End Sub
Function SheetExistsOrCreate(name As Variant)
For i = 1 To Worksheets.Count
If Worksheets(i).name = "MySheet" Then
exists = True
End If
Next i
If Not exists Then
Worksheets.Add.name = name
End If
End Function
Please, try the next adapted code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 And Target.Cells.Count = 1 Then
Application.EnableEvents = False
If LCase(Target.Value) = -1 Then
Target.EntireRow.Delete
ElseIf Target.Value = 1000 Then
With Target.EntireRow
.Copy Sheets("Week Schedule").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Delete
End With
End If
Application.EnableEvents = True
End If
End Sub
The above code assumes that the Target value means a number, not a string looking as a number. If a string, you can place them between double quotes, as in your initial code.
Of course, a sheet named "Week Schedule" must exist in the active workbook and must not be protected.
I'm using Worksheet_Change to make a value (either 1 or 0) appear in the next cell (Bx) when a value is entered in a range of cells (A1:A10).
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
If Target.Value = 1 Then
Target.Offset(0, 1).Value = 1
Else:
Target.Offset(0, 1).Value = 0
End If
End If
End Sub
The problem occurs when I try to clear the cells in column A.
When I select the cells I want to clear and press "Delete" I get "Run-time error '13' - Type mismatch" on the line "IF Target.Value = 1".
I would also like the cells in the B column to be cleared if I clear cells in the A column. E.g. if I delete cell A2:A5, B2:B5 should be cleared.
From what I understand the problem is that when selecting multiple cells it returns an array as the Target, and this is a mismatch with the Integer.
Is there a way around this problem?
Try this. You need to cater for multiple cells in some way, for the reasons you mention, and add an extra clause to your If.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, r1 As Range
Set r = Intersect(Target, Range("A1:A10"))
If Not r Is Nothing Then
For Each r1 In r
If r1.Value = 1 Then
r1.Offset(0, 1).Value = 1
ElseIf r1.Value = vbNullString Then
r1.Offset(0, 1).Value = vbNullString
Else
r1.Offset(0, 1).Value = 0
End If
Next r1
End If
End Sub
In a first step we add the functionality that multiple cells are selected and changed:
Private Sub Worksheet_Change_Var1(ByVal Target As Range)
Dim targetCell As Range
'If Target.Range.count
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
If Target.Cells.Count > 1 Then
For Each targetCell In Target
If targetCell.Value = 1 Then
targetCell.Offset(0, 1).Value = 1
Else
targetCell.Offset(0, 1).Value = 0
End If
Next targetCell
Else
If Target.Value = 1 Then
Target.Offset(0, 1).Value = 1
Else
Target.Offset(0, 1).Value = 0
End If
End If
End If
End Sub
In the 2nd step we understand that also the "one cell" case can be handled in the same way and we add an if clause for the "cell(s) cleared" case:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim targetCell As Range
'If Target.Range.count
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
For Each targetCell In Target
If targetCell.Value = 1 Then
targetCell.Offset(0, 1).Value = 1
Else
targetCell.Offset(0, 1).Value = 0
End If
'if cell in col A is empty, then clear cell in col B
If targetCell.Value = "" Then targetCell.Offset(0, 1).ClearContents
Next targetCell
End If
End Sub
I am currently running code that changes cell colour and value when clicked i.e. one click changes cell colour and sets value to 1, double click same cell to remove colour and number. This is to allow people to fill in a form in a visual way, and gives me the ability to count the "checked" cells. My problem is that I need it restricted to a certain range within that worksheet so that people can't overwrite other cells.
I have next to no coding experience, and the code below is a mix and match of a bunch of stuff found online.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
Worksheet_SelectionChange Target
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With Target
If .Range("E4:K79") Is Nothing Or .Count > 1 Then Exit Sub
Select Case .Value
Case ""
.Interior.ColorIndex = 40
Case 1
.Interior.ColorIndex = xlNone
.Value = vbNullString
Exit Sub
Case Else
Exit Sub
End Select
.Value = .Value + 1
End With
End Sub
Solved.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
Worksheet_SelectionChange Target
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With Target
If Intersect(.Cells, Range("E4:K120")) Is Nothing Or .Count > 1 Then Exit Sub
Select Case .Value
Case ""
.Interior.ColorIndex = 3
Case 1
.Interior.ColorIndex = xlNone
.Value = vbNullString
Exit Sub
Case Else
Exit Sub
End Select
.Value = .Value + 1
End With
End Sub
I have a VBA like below but when i copy more then 1 cell i get a error because of the multiple selection.
Is it possible to make a action that the Case looks at the selected cells one after the other? Or do i have the wrong Statment?
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("$G$8:$OA$92")) Is Nothing Then
With Target
Select Case .Value
Case Is = "Weekend"
.Interior.ColorIndex = 48
Case Is = "VRIJ", "ADV"
.Interior.ColorIndex = 6
End Select
End With
End If
End Sub
Loop through the cells in the intersect.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("G8:OA92")) Is Nothing Then
on error goto meh
application.enableevents = false
dim t as range
for each t in Intersect(Target, Range("G8:OA92"))
With t
Select Case lcase(.Value2)
Case "weekend"
.Interior.ColorIndex = 48
Case "vrij", "adv"
.Interior.ColorIndex = 6
case else
.interior.pattern = xlnone
End Select
End With
next t
End If
meh:
application.enableevents = true
End Sub
I have been looking for days to solve this and have only come up with half the solution.
What I can do:
I would simply like to have one cell turn green inside with an x inserted when another cells data has the word "Complete" inside it.
What I cannot do:
I would like that same cell that turned green with an x inserted into it when the word "Complete" is changed to "Rework" to stay green with an x.
So Cell A1 is blank then in cell B1 the word "Complete" is added. Then cell A1 changes to green and has an x inside it. If later B1 changes to "Rework" I would like A1 to stay green with the x inside. So I can know that at one time the status of B1 was at one time "Complete"
I have been trying Conditional Formatting with rules but cannot get it to stay. I think the "Stop If True" check box within would be part of the solution but not sure what the code would be.
I already have a different macro running on this sheet so if the answer is a macro I will need it to be added to it. Below is the macro in the sheet already. Thank you.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("N:N,Y:Y"), Range("10:" & Rows.Count)) Is Nothing Then
If Target.Count < Columns.Count Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
Dim r As Range
For Each r In Intersect(Target, Range("N:N,Y:Y"), Range("10:" & Rows.Count))
With r.Offset(0, 1)
.Value = Now 'use Now to retain the time as well as the date
.NumberFormat = "mm/dd/yy" 'change to what you prefer
End With
Next r
End If
End If
bm_Safe_Exit:
Application.EnableEvents = True
End Sub
Ideally you'd split this up into separate subs to handle each of the change types, but this should give you an idea:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, r as Range
'skip full-row changes (row insert/delete?)
If Target.Columns.Count = Columns.Count Then Exit Sub
Set rng = Intersect(Target, Range("N:N,Y:Y"), Range("10:" & Rows.Count))
If Not rng Is Nothing Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
For Each r In rng.Cells
With r.Offset(0, 1)
.Value = Now 'use Now to retain the time as well as the date
.NumberFormat = "mm/dd/yy" 'change to what you prefer
End With
Next r
End If
Set rng = Intersect(Target, Range("B:B"), Range("10:" & Rows.Count))
If Not rng Is Nothing Then
On Error GoTo bm_Safe_Exit
Application.EnableEvents = False
For Each r In rng.Cells
If r.Value = "Complete" Then
With r.Offset(0, -1)
.Value = "x"
.Interior.Color = vbGreen
End With '<<EDIT thanks #BruceWayne
End If
Next r
End If
bm_Safe_Exit:
Application.EnableEvents = True
End Sub
You'll need two worksheet events, and some If statements. The following should help you get started, unless I'm overlooking something.
Dim oldVal as String ' Public variable
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Debug.Print Target.Address
If Target.Cells.Count <> 1 Then Exit Sub
oldVal = Target.Value
End Sub
The above will make note of the oldValue.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim newVal As String
newVal = Target.Value
If newVal = oldVal Then
Debug.Print "Same Values"
ElseIf oldVal = "Complete" And newVal = "Rework" Then
Debug.Print "Stay green with X"
ElseIf oldVal = "" And (newVal = "Complete" Or newVal = "complete") Then
Debug.Print "Change cell to Green, add an 'X'"
Target.Interior.ColorIndex = 10
Target.Value = Target.Value & " x"
End If
End Sub
Then, add/tweak those If statements as necessary, and add the color changing/reverting code to the appropriate block.
(There may of course be a better mousetrap, but I think this should get you going).