I am creating a spreadsheet where people are to enter when something has been completed. I figured the most efficient way would be to use double click tick boxes. However, I want to pull the user ID and the timestamp for this, and don't want anyone to be able to edit anything except if they are double clicking something for the first time.
I have the below which works for what I need but I don't know how to protect the sheet exactly as I wish.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'Limit Target count to 1
If Target.Count > 1 Then Exit Sub
'Isolate Target to a specific range
If Intersect(Target, Range("Ckboxes")) Is Nothing Then Exit Sub
'Set Target font to "marlett"
Target.Font.Name = "marlett"
'Check value of target
If Target.Value <> "a" Then
Target.Value = "a" 'Sets target Value = "a"
Target.Offset(0, 1).Value = Environ("UserName")
Target.Offset(0, 2).Value = Format(Now, "yyyy-mm-dd hh:mm:ss")
Cancel = True
Exit Sub
End If
If Target.Value = "a" Then
Cancel = True
Exit Sub
End If
End Sub
Also, if I protect columns C and D then it won't let the macro enter the values needed there. I know I may need to protect the whole worksheet and have it unlock the cells upon a double click to allow the change to happen and then lock again straight after but I can't figure out how to manage that!
Any help is appreciated!
What you could do is protect the sheet as usual and put in the check-boxes. Then assign this macro to all the checkboxes -
Sub ChkBxClk()
Dim shp As Shape
Set shp = ActiveSheet.Shapes(Application.Caller)
If shp.ControlFormat.Value = xlOff Then
MsgBox ("This was already checked off")
shp.ControlFormat.Value = xlOn
Exit Sub
End If
If shp.ControlFormat.Value = xlOn Then
ActiveSheet.Unprotect
Dim rng As Range
Set rng = Range(shp.TopLeftCell.Address)
rng.Offset(0, 1).value = Environ("UserName")
rng.Offset(0, 2).value = Format(Now, "yyyy-mm-dd hh:mm:ss")
ActiveSheet.Protect
End If
End Sub
Now, if a user checks a box (which is allowed on a protected sheet), it will unlock and allow you to enter what you want in the offset cells.
Related
I have a spreadsheet that has data validation in cells A2-A999 with the only option in the drop down menu being "Today" (without the quotation marks). I have a VBA code that changes the cell's value to today's date when "Today" is selected in the cell. However, this code has a problem. When I clear the contents of a group of cells, including the cell that has today's date in it, the spreadsheet thinks, then debugs and then closes; for example clearing A1 & B1 simultaneously.
However, if I clear A1 by itself, it clears the cell with no problems.
P.S. By " I clear", I meant to say: "I select the group of cells with the mouse and then hit the backspace button."
Can you guys help me fix the code so that I can clear many cells at the same time, including the cell with data validation.
The code that I am using is pasted in the worksheet section and is as the following:
Private Sub Worksheet_Change(ByVal Target As Range)
selectedVal = Target.Value
If Target.Column = 1 Then
selectedNum = Application.VLookup(selectedVal, Worksheets("DATA-
O").Range("DateToday"), 2, False)
If Not IsError(selectedNum) Then
Target.Value = selectedNum
End If
End If
End Sub
The answer to your problem is (as Dirk Reichel just mentioned in a comment) to loop through each of the affected cells:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
If Not Intersect(Columns(1), Target) Is Nothing Then
For Each c In Intersect(Columns(1), Target).Cells
selectedVal = c.Value
selectedNum = Application.VLookup(selectedVal, Worksheets("DATA-O").Range("DateToday"), 2, False)
If Not IsError(selectedNum) Then
Application.EnableEvents = False 'As recommended by K Paul
c.Value = selectedNum
Application.EnableEvents = True
End If
Next
End If
End Sub
However, based on what you say that the code is doing, I'm not sure why you don't just use:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
If Not Intersect(Columns(1), Target) Is Nothing Then
For Each c In Intersect(Columns(1), Target).Cells
If c.Value = "Today" Then
Application.EnableEvents = False 'As recommended by K Paul
c.Value = Date
Application.EnableEvents = True
End If
Next
End If
End Sub
If you want to be fast, there are 2 ways.
Use Evaluate to do it array-like:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Columns(1), Target) Is Nothing Then
With Intersect(Columns(1), Target)
If Evaluate("AND(" & .Address & "<>""Today"")") Then Exit Sub
.Value = Evaluate("IF(" & .Address & "=""Today"",TODAY()," & .Address & ")")
End With
End If
End Sub
or use Range.Replace which also can be very fast:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Columns(1), Target) Is Nothing Then
Intersect(Columns(1), Target).Replace "Today", Date, xlWhole, , True, , False, False
End If
End Sub
A small hint: hitting ctrl & ; will directly input todays date
I've read a few others which partially resolved my issue but being a complete VB amateur I can't get this to work. The worksheet in question is protected so have tried adding in a protect/unprotect command in the code. It will unprotect fine at the start but then encounters problems. Any help would be appreciated.
Private Sub Worksheet_Change(ByVal Target As Range)
Sheet1.Unprotect Password:="mypassword"
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("B11")) Is Nothing Then
Select Case Target.Value
Case Is = ""
Target.Value = "Product Name (IE Product123)"
Target.Font.ColorIndex = 15
Case Else
Target.Font.ColorIndex = 1
End Select
End If
If Not Intersect(Target, Range("B12")) Is Nothing Then
Select Case Target.Value
Case Is = ""
Target.Value = "Version "
Target.Font.ColorIndex = 15
Case Else
Target.Font.ColorIndex = 1
End Select
End If
Sheet1.Protect Password:="mypassword"
End Sub
You have not turned off the Application.EnableEvents property but there is a chance that you will write something to the worksheet. This would retrigger the event handler and the Worksheet_Change event macro would try to run on top of itself.
There is nothing preventing someone from simultaneously clearing the contents of both B11 and B12. Rather than abandoning the processing, accommodate the possibility and process both cells if there are two cells in target.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B11:B12")) Is Nothing Then
On Error GoTo bm_Safe_Exit
'turn off event handling 'cause we might write something
Application.EnableEvents = False
'why this unprotect necessary??
'Me.Unprotect Password:="mypassword"
Dim rng As Range
For Each rng In Intersect(Target, Range("B11:B12"))
Select Case rng.Value2
Case vbNullString
If rng.Address(0, 0) = "B11" Then
rng = "Product Name (IE Product123)"
Else
rng = "Version " '<~~ why the trailing space??
End If
rng.Font.ColorIndex = 15
Case Else
rng.Font.ColorIndex = 1
End Select
Next rng
End If
bm_Safe_Exit:
'if unprotect is not necessary, neither is protect
'Me.Protect Password:="mypassword"
Application.EnableEvents = True
End Sub
You might also want to look into the UserInterfaceOnly parameter of the Worksheet.Protect method. Setting this to true allows you to do anything you want in VBA without unprotecting the worksheet.
Addendumm:
If the user can alter the contents of B11:B12 then these cells must not be locked. If they are not locked then there is no need to unprotect the worksheet before (possibly) altering their contents.
My problem is I'm trying to make a cell cannot be edited by the users after the inputs are given e.g. I want to let the user input something from cell C22-C28 then after the user inputs the cell, that specific cell shouldn't be edited. What should be the best solution for this? Any suggestions?
Take a look at this question
How to Lock the data in a cell in excel using vba
where are multiple nice answers. In basic, you need to set your range to .locked and then protect sheet via .protect, for more develop info try to look at msdn
Edit: so you can use this as mentioned in this question (Restricting the user to delete the cell contents)
Without lock and unlock, you can use this. We have there one global variable to store selection value (to preserve beforechange state). Function SelectionChange, updating value of current cell, so we can restore cell value after users try.
Sub worksheet_change just controling, if user targeting specified row and column (can be adjusted for whole range), and if he try to change value, he is prompted and value is set back.
Dim prevValue As Variant
Private Sub worksheet_SelectionChange(ByVal target As Range)
prevValue = target.Value
End Sub
Private Sub worksheet_change(ByVal target As Range)
If target.Row = 5 And target.Column = 5 Then
If target.Value <> prevValue Then
target.Value = prevValue
MsgBox "You are not allowed to edit!", vbCritical + vbOKOnly
End If
End If
End Sub
Maybe you can try the code below:
Option Explicit
Public OriginalCell As Range
Public ProtectedCell As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ws As Worksheet
Dim lastRow As Long
Set ws = ThisWorkbook.Worksheets("Sheet1")
lastRow = Cells(Rows.Count, 3).End(xlUp).Row + 1
If Not Intersect(Target, Range("C1:D" & ws.Range("C" & ws.Rows.Count).End(xlUp).Row)) Is Nothing Then
Application.ScreenUpdating = False
Set ProtectedCell = Target
MsgBox "Access Denied", vbExclamation, "Access Status"
Cells(lastRow, 3).Select
Application.ScreenUpdating = True
End If
Hope it will help solve your problem.
I am creating a survey that I want to be simple for the end user. I have created a document that operates on a Likert scale, where things range from Disagree to Agree on a 6 point scale (with a no answer field). The questions I have run on rows 3 to 152 and the choices are in cells C:H on each row. Currently, I have it to where the taker can click on a cell and produce an X in the box, indicating their choice. I also have it so that they may only click one option in the row, and if they select another option, it removes the first X and places the X in the new cell that they have clicked.
Here is what I want. Right now, if they place an X in a cell, and click that same X, my code goes through and takes the X away and replaces it again with that same X. I would like it to replace the clicked X with nothing, so that it can toggle on and off with a click. I want to keep it so that if they select another cell in the same row, the X in the original cell disappears and the X pops up in the clicked cell, however. I only want them to be able to select one cell in each row for each question. Sorry for the length, but I just wanted to be clear. Here is my code currently.
Thanks for any help you can offer!
Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rInt As Range
Dim rCell As Range
For rw = 3 To 152
Set rInt = Intersect(Target, Range("C" & rw & ":H" & rw))
If Not rInt Is Nothing Then
If Application.WorksheetFunction.CountA(Range("C" & rw & ":H" & rw)) > 0 Then
Range("C" & rw & ":H" & rw).Value = ""
End If
For Each rCell In rInt
If rCell.Value = "" Then
rCell.Value = "X"
End If
Next
End If
Set rInt = Nothing
Set rCell = Nothing
Cancel = True
Next
End Sub
Try the below code. Notice I removed your loop; there's no reason to loop through every row when we can pinpoint the row the user selected and focus on that row. I also changed the way rInt is set, replaced the CountA function with .Find, and wrapped the entire procedure with a test to see whether the user has selected a cell in our predefined range (so the code doesn't needlessly run when other cells are selected).
Option Explicit
Sub Worksheet_SelectionChange(ByVal Target As Range)
'Only run the code if the user selected a cell in our defined range:
If Not Intersect(Target, Me.Range("C3:H152")) Is Nothing Then
'Declare variables
Dim rInt As Range
Dim rCell As Range
Dim rw As Long
Dim xLoc As Range
Set rInt = Me.Range(Me.Cells(Target.Row, "C"), Me.Cells(Target.Row, "H"))
If Not rInt Is Nothing Then
'Look for a response in our answer range
Set xLoc = rInt.Find("x")
If Not xLoc Is Nothing Then
'If there was a response and the response was in the same column _
'we selected, wipe the response and exit the sub.
If Target.Column = xLoc.Column Then
rInt.Value = vbNullString
Exit Sub
'Else, wipe the previous response and add the new response
Else
rInt.Value = vbNullString
Target.Value = "x"
End If
'If there were no previous responses...
Else: Target.Value = "x"
End If
End If
End If
End Sub
All you need here are radio buttons that are linked to a cell and then edit the click code.
Private Sub OptionButton1_Click()
Range("D3:H3") = False
Range("C3") = True
End Sub
Private Sub OptionButton2_Click()
Range("C3") = False
Range("D3") = True
Range("E3:H3") = False
End Sub
Then format the cells to make the text the same color as the background and use conditional formatting to change the color of the cell the radio button is in front of by referencing the TRUE or FALSE, very nice for the user and easy.
I'm guessing you haven't used them before so just so you know, you go to the developer tab, I always use the ActiveX radio buttons. Then use design mode to edit the properties of the option button, and change "GroupName" to link any the radio buttons together where you only want one to be clicked by naming them with the same group name.
I would like to start off with stating that I have virtually no coding experience. I found a VBA snippet online for highlighting an entire selected range (just to as a visual guide):
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
Application.ScreenUpdating = False
' Clear the color of all the cells
Cells.Interior.ColorIndex = 0
With Target
' Highlight the entire column that contain the active cell
.EntireRow.Interior.ColorIndex = 8
End With
Application.ScreenUpdating = True
End Sub
I would like to also have the cursor jump-to column "J". For instance, after performing a search for cells containing the words "strawberry topping" after pressing 'OK' the cell containing that text becomes active and, due to the VBA code, the entire row is highlighted.
The first cell I need to work on is in column "J". Can I also have column J selected along with the row being highlighted?
Thank you so much for your time and would appreciate any help you may have to offer.
My Three cents
If you are using xl2007+ then do not use Target.Cells.Count. Use Target.Cells.CountLarge else you will get an Overflow error if a user tries to select all cells by pressing CTRL + A as Target.Cells.Count can't hold a Long value.
If you want to select the row and the column, you might want to switch off events else you might end up in endless loop.
Since you are working with events, use error handling.
Is this what you are trying?
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Rw As Long, Col As Long
Dim ColName As String
On Error GoTo Whoa
If Target.Cells.CountLarge > 1 Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
' Clear the color of all the cells
'Cells.Interior.ColorIndex = 0
With Target
Rw = .Row
Col = .Column
ColName = Split(Cells(, Col).Address, "$")(1)
' Highlight the entire column that contain the active cell
'.EntireRow.Interior.ColorIndex = 8
Range(ColName & ":" & ColName & "," & Rw & ":" & Rw).Select
End With
LetsContinue:
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
End Sub