This is what I want to do. I have five columns (A,B,C,D,E). My requirement is that in each row, only one cell should accept data, and the remaining cells should not accept data (i.e. the remaining four cells should be in locked mode).
eg if the user enter 1 in column 1, BCDE will be lock but if the user decides to change the option they can put back original data and change to another value in a column. Below is a sample of what I am trying to do.
VeryStrong Strong Neutral Weak VeryWeak
1 0 0 0 0 Data keyed by user 1
0 1 0 0 0 Data keyed by user 2
0 1 1 0 0 *This is what I am trying to prevent*
User 1 can go back and change
Private Sub Worksheet_Change(ByVal Target As Range)
Me.Unprotect
If Not IsEmpty(Target) Then
'Data was added in target cell. Lock its neighbours.
Me.Cells(Target.Row, 1).Resize(, 5).Locked = True
Target.Locked = False
Else
'Data was erased from target cell. Release its neighbours.
Me.Cells(Target.Row, 1).Resize(, 5).Locked = False
End If
Me.Protect
End Sub
I am trying to figure out the code and change the relevant to specific columns eg K9,L9,M9,N9,O9. – Timothy Teoh 27 mins ago
Try this. (TRIED AND TESTED)
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MyPass As String
Dim Rw As Long
MyPass = "Sid" '<~~ Change this to your password
On Error GoTo Whoa
If Target.Cells.CountLarge > 1 Then Exit Sub
Application.EnableEvents = False
If Not Intersect(Target, Range("K:O")) Is Nothing Then
Rw = Target.Row
ActiveSheet.Unprotect MyPass
Select Case Target.Value
Case Is > 0
Range("K" & Rw & ":O" & Rw).Locked = True
Target.Locked = False
Case 0
Range("K" & Rw & ":O" & Rw).Locked = False
End Select
End If
Letscontinue:
ActiveSheet.Protect MyPass
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
Related
I did a post yesterday asking how to clear adjacent dropdown lists when parent list changes. I was able to find a post, adjust my code, and get it to work.
Now the issue I'm facing is that I need it to be optional:
If the column 1 changes, then clear offset column B & C cells.
If the change is selected in column 2, then only clear offset column C cell.
Below is my code so far - it works when making the change in column A, but I need it be optional if I only make the change in column B, and clear the adjacent cell in column C.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count < 1 Then Exit Sub 'screen out multi-cell changes
If Target.Column <> 1 Then Exit Sub 'col2 only
If Not CellHasValidation(Target) Then Exit Sub '...with validation
On Error GoTo haveError 'ensure events are not left off
Application.EnableEvents = False
Target.Offset(0, 1).Value = ""
Target.Offset(0, 2).Value = ""
Target.Offset(0, 1).Interior.ColorIndex = 44
Target.Offset(0, 2).Interior.ColorIndex = 44
Application.EnableEvents = True
Exit Sub
haveError:
MsgBox Err.Description
Application.EnableEvents = True
End Sub
'check if a cell has validation
Function CellHasValidation(cell As Range) As Boolean
Dim vt
On Error Resume Next 'ignore if error (no validation)
vt = cell.Validation.Type
On Error GoTo 0 'stop ignoring errors
CellHasValidation = Not IsEmpty(vt)
End Function
You can use a loop:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long
If Target.CountLarge <> 1 Then Exit Sub 'screen out multi-cell changes
If Target.Column > 2 Then Exit Sub 'col 1/2
If Not CellHasValidation(Target) Then Exit Sub '...with validation
On Error GoTo haveError 'ensure events are not left off
Application.EnableEvents = False
'loop to max column to be cleared
For i = Target.Column + 1 To 3
With Target.EntireRow.Cells(i)
.Value = ""
.Interior.ColorIndex = 44
End With
Next i
Application.EnableEvents = True
Exit Sub
haveError:
MsgBox Err.Description
Application.EnableEvents = True
End Sub
'check if a cell has validation
Function CellHasValidation(cell As Range) As Boolean
Dim vt
On Error Resume Next 'ignore if error (no validation)
vt = cell.Validation.Type
On Error GoTo 0 'stop ignoring errors
CellHasValidation = Not IsEmpty(vt)
End Function
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 have a trigger that I want to use in certain worksheet - just inside 2 specific columns. But whan I enter a value inside another range it triggers the Private Sub of that worksheet.
I want it would start to work just whan I cange value within columns E or H.
Is someone knows how to do it right?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim LR As Long
Dim rng1 As Range
Dim rng2 As Range
'WE WANT TO KEEP THE TARGET COLUMNS BETWEEN 0% TO 100%
LR = Cells(Rows.Count, "A").End(xlUp).Row
Set rng1 = Intersect(Target, Range(Cells(2, "E"), Cells(LR, "E")))
On Error GoTo 1
If Target.Value < 0 Or Target.Value > 1 Then
MsgBox "bla bla bla", vbCritical + vbMsgBoxRtlReading + vbMsgBoxRight, "error"
Target.Value = 0
Exit Sub
End If
On Error GoTo 1
Set rng2 = Intersect(Target, Range(Cells(2, "H"), Cells(LR, "H")))
If Target.Value < 0 Or Target.Value > 1 Then
MsgBox "bla bla bla", vbCritical + vbMsgBoxRtlReading + vbMsgBoxRight, "error"
Target.Value = 0
Exit Sub
End If
1
End Sub
You just need to check if Target intersects with your desired range. I would Union the two columns together in this check.
As cryptically stated by DisplayName, since Target can contain more than one cell, you should check each cell in target individually. Alternatively, if your intention for Target was to always have one cell, then you can avoid the For...Each statement altogether and use this check: If Target.Cells.Count > 1 Then Exit Sub to not run the procedure when more than 1 cell is changed.
I also added another intersect target, Me.Rows("2:" & rows.count) to avoid updating any headers you may have. If your data does not contain headers, then you can remove this range from Intersect().
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo safeExit
Dim rngIntersect As Range
Set rngIntersect = Intersect(Target, Union(Me.Columns("E"), Me.Columns("H")), _
Me.Rows("2:" & Rows.Count))
If Not rngIntersect Is Nothing Then
Application.EnableEvents = False
Dim cel As Range
For Each cel In rngIntersect
If cel.Value < 0 Or cel.Value > 1 Then
MsgBox "bla bla bla", vbCritical + vbMsgBoxRtlReading + vbMsgBoxRight, _
"error"
cel.Value = 0
End If
Next cel
End If
safeExit:
Application.EnableEvents = True
End Sub
As a side note, when you are using the same exact range more than once, it's not a bad idea to go ahead and set that range to a variable. So, we use rngIntersect twice in this code, so this prevents us from having to issue multiple calls to the Intersect() and Union() functions. On top of that, you run into less debugging headaches when you only have to update the range in one place rather than multiple times in your code.
The intersect can check if any of the cells in Target (yes, Target can be more than a single cell) intersect with the Union of columns E and H.
Private Sub Worksheet_Change(ByVal Target As Range)
' this next line could also be,
'If Not Intersect(Target, Range("E:E, H:H")) Is Nothing Then
If Not Intersect(Target, Union(Range("E:E"), Range("H:H"))) Is Nothing Then
On Error GoTo bye_bye
Application.EnableEvents = False
Dim t As Range
For Each t In Intersect(Target, Union(Range("E:E"), Range("H:H")))
If (t.Value2 < 0 Or t.Value2 > 1) And t.Row > 1 Then
MsgBox "bla bla bla", vbCritical + vbMsgBoxRtlReading + vbMsgBoxRight, "error"
t = 0
End If
Next t
End If
bye_bye:
Application.EnableEvents = True
End Sub
In my sheet columns B:C allow dates. I'm trying to create a check to see whether a date entered in C is more recent than B, if so fine, else alert the user and clear contents.
My code returns a run-time error 91 in the application.intersect line:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Dates As Range
Set Dates = Range("C4:C12")
If Target.Cells.Count > 1 Or IsEmpty(Target) Then
Exit Sub
End If
If Not Application.Intersect(Dates, Range(Target.Address)).Value > ActiveCell.Offset(0, -1).Value Then
GoTo DatesMissMatch
Else
Exit Sub
End If
DatesMissMatch:
Target.ClearContents
ActiveCell.Value = "A2"
MsgBox "Please re-check dates"
End Sub
I changed your method, but this seems to be working.
I also noticed that you were writing A2 to ActiveCell instead of Target. Did you want the cell in column C to update if invalid data is entered or did you intend for it to be whichever cell you move to that gets changed?
At any rate, here's a way I came up with it
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Or IsEmpty(Target) Then
Exit Sub
End If
If Target.Column = 3 Then 'Check to see if column C was modified
If Target.Value < Target.Offset(0, -1).Value Then
Target.ClearContents
Target.Value = "A2"
MsgBox "Please re-check dates"
End If
End If
End Sub
If you want to stick with the way you are currently doing it, then I think you need to check that the Intersection is not empty as another answer concludes.
I believe you just have to check the intersect than do the compare.
Sub Worksheet_Change(ByVal Target As Range)
Dim Dates As Range
Set Dates = Range("C4:C12")
If Target.Cells.Count > 1 Or IsEmpty(Target) Then
Exit Sub
End If
If Not Application.Intersect(Dates, Range(Target.Address)) Is Nothing Then
If Target.Value < Target.Offset(0, -1).Value Then
GoTo DatesMissMatch
Else
Exit Sub
End If
End If
DatesMissMatch:
Target.ClearContents
ActiveCell.Value = "A2"
MsgBox "Please re-check dates"
End Sub
You can just loop the rows and compare the dates.
Dim ws As Excel.Worksheet
Set ws = Application.ActiveSheet
Dim lRow As Long
lRow = 4
Do While lRow <= ws.UsedRange.Rows.count
If ws.Range("C" & lRow).Value > ws.Range("B" & lRow).Value then
GoTo DatesMissMatch
End if
lRow = lRow + 1
Loop
I have code that retrieves information from SQL and VFP and populates a dropdown list in every cell in column "A" except A1 - this is a header.
I need to populate the "G" column on the row where the user selects the value from a dropdown in the "A" column.
I believe I need to be in Private Sub Worksheet_SelectionChange(ByVal Target As Range) which is in the sheet object.
Below is something similar to what I want to do.
If cell "a2".valuechanged then
Set "g2" = "8000"
End if
If cell "a3".valueChanged then
Set "g3" = "8000"
End if
The code above doesn't work, but I think it is easy to understand. I want to make this dynamic, so I don't have too many lines of code.
I have already explained about events and other things that you need to take care when working with Worksheet_Change HERE
You need to use Intersect with Worksheet_Change to check which cell the user made changes to.
Is this what you are trying?
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Whoa
'~~> Check if user has selected more than one cell
If Target.Cells.CountLarge > 1 Then Exit Sub
Application.EnableEvents = False
'~~> Check if the user made any changes in Col A
If Not Intersect(Target, Columns(1)) Is Nothing Then
'~~> Ensure it is not in row 1
If Target.Row > 1 Then
'~~> Write to relevant cell in Col G
Range("G" & Target.Row).Value = 8000
End If
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
Try this
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row > 1 And Target.Column <> 7 Then
Cells(Target.Row, "G").Value = 8000
End If
End Sub
If you only need it to fire on column A then
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Row > 1 And Target.Column = 1 Then
Cells(Target.Row, "G").Value = 8000
End If
End Sub
can you not put an if statement in column G , as in
If (A1<>"", 8000,0)
Other wise something like this will get you going:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Column = 1 Then
If Target.Value2 <> "" Then
Target.Offset(0, 6) = "8000"
Else
Target.Offset(0, 6) = ""
End If
End If
On Error GoTo 0
End Sub
Thanks
Ross
I had a similar problem. I used Siddharth Rout's code. My modifications allow a user to paste a range of cells in column a (ex. A3:A6) and have multiple cells modified (ex. H3:H6).
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Whoa
'~~> Check if user has selected more than one cell
If Target.Cells.CountLarge < 1 Then Exit Sub
If Target.Cells.CountLarge > 500 Then Exit Sub
Debug.Print CStr(Target.Cells.CountLarge)
Application.EnableEvents = False
Dim the_row As Range
Dim the_range As Range
Set the_range = Target
'~~> Check if the user made any changes in Col A
If Not Intersect(the_range, Columns(1)) Is Nothing Then
For Each the_row In the_range.Rows
'~~> Ensure it is not in row 2
If the_row.Row > 2 Then
'~~> Write to relevant cell in Col H
Range("H" & the_row.Row).Value = Now
End If
Next
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub