How to disable changes in a cell using vba? - vba

I am working with the bellow code:
This code do for Example: If I input any value in cell A1, cell B1 display a time stamp.
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
With Target
If .Count > 1 Then Exit Sub
If Not Intersect(Range("B1:B10"), .Cells) Is Nothing Then
Application.EnableEvents = False
If IsEmpty(.Value) Then
.Offset(0, 1).ClearContents
Else
With .Offset(0, 1)
.NumberFormat = "hh:mm AM/PM"
.Value = Now
End With
End If
Application.EnableEvents = True
End If
End With
End Sub
What I am trying to do now is to protect/not editable from the user the cell "B1:B10" once time stamp has made by the macro. I google on how to protect but I am having hard time to insert those code I found. Can anyone help me how I construct/insert this code to my original code?
Private Sub Worksheet_Change(ByVal Target As Range)
'set your criteria here
If Target.Column = 1 Then
'must disable events if you change the sheet as it will
'continually trigger the change event
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
MsgBox "You cannot do that!"
End If
End Sub
Or this code:
'select the cell you want to be editable
Worksheets("Sheet1").Range("B2:C3").Locked = False
'then protect the entire sheet but still vba program can modify instead.
Worksheets("Sheet1").Protect UserInterfaceOnly:=True
Thanks to Kazjaw. Here is the final code.
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
'Protect cell "B1:B10"
Worksheets("Sheet1").Cells.Locked = False
Worksheets("Sheet1").Range("B1:b10").Locked = True
Worksheets("Sheet1").Protect Password:="pass", UserInterfaceOnly:=Tru
With Target
If .Count > 1 Then Exit Sub
If Not Intersect(Range("B1:B10"), .Cells) Is Nothing Then
Application.EnableEvents = False
If IsEmpty(.Value) Then
.Offset(0, 1).ClearContents
Else
With .Offset(0, 1)
.NumberFormat = "hh:mm AM/PM"
.Value = Now
End With
End If
Application.EnableEvents = True
End If
End With
End Sub

If you want to protect only Range B1:B10 then you need to run this sub only once:
Sub ProtectCellsInB()
Worksheets("Sheet1").Cells.Locked = False
Worksheets("Sheet1").Range("B1:b10").Locked = True
Worksheets("Sheet1").Protect Password:="pass", UserInterfaceOnly:=True
End Sub
I made a modification- I added a password to protection which you can delete.
If you are not sure how to run it once then you could add the whole internal code at the end of your Private Sub Worksheet_Change(ByVal Target As Excel.Range)

Related

VBA recognizing more than one cell is highlighted

I have the following VBA script:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.ScreenUpdating = False
If Not Application.Intersect(Target, Range("calendar")) Is Nothing Then
[selectedCell1] = ActiveCell.Value
Application.ScreenUpdating = True
End If
End Sub
Currently, It recognizes only one cell is highlighted and returns it into the specific cell named selectedCell1.
This is my example:
If I select the cell N25 which contains the date "03/08/2017" it returns "03/08/2017" into another sheet cell named "selectedCell1".
But what I would like it to do, is realize I've selected the entire week, and then return that entire week range in cell "selectedCell1". See:
And then return 01/08/2017 - 05/08/2017 (that entire range) in cell "selecetedCell1".
Not sure how to adjust this VBA script. Help would be appreciated. Thanks.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Application.ScreenUpdating = False
If Not Application.Intersect(Target, Range("calendar")) Is Nothing Then
If Target.Cells.Count = 1 Then
[selectedCell1] = Target.Value
Else
[selectedCell1] = Format(Application.WorksheetFunction.Min(Target), "dd/mm/yyyy") & " - " & Format(Application.WorksheetFunction.Max(Target), "dd/mm/yyyy")
End If
Application.ScreenUpdating = True
End Sub

Dynamic hyperlink that filters a table based on the ActiveCell value (VBA)

I'm creating a dynamic hyperlink that will filter a table on another sheet (Sheet15).
My goal is to have the user be able to select a cell on Sheet3 and have the VALUE of this cell be the filter on the other sheet.
Here is my code so far:
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
If Target.Type = msoHyperlinkRange And Target.Range.Address = "$S$15" Then
Application.ScreenUpdating = False
Sheet15.Visible = True
Sheet15.ListObjects("Table17").Range.AutoFilter Field:=19, Criteria1:=ActiveCell.Value
Sheet15.Activate
Application.ScreenUpdating = True
End If
End Sub
However, when I click the hyperlink, the table is not filtered at all, so I gotta be doing something wrong.
Can anyone assist?
UPDATE
Here is updated code.
Cell S17 is now the value that I want to filter the table to:
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
If Target.Type = msoHyperlinkRange And Target.Range.Address = "$S$15" Then
Application.ScreenUpdating = False
Sheet15.Visible = True
Sheet15.ListObjects("Table17").Range.AutoFilter Field:=19, Criteria1:=Sheet3.Range("S17").Value
Sheet15.Activate
Application.ScreenUpdating = True
End If
End Sub
But the issue remains. When I click they hyperlink, I will be brought to this other sheet, but the table is not filtered at all.
sticking to your original plans, and assuming column "A" is the one with cities names, place the following in your worksheet code pane
Option Explicit
Dim lastCell As Range '<--| declare a module scoped range variable to store the last cell selected by the user, if "valid"
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$S$15" Then Exit Sub '<-- do nothing if user selected cell with hyperlink
Set lastCell = Intersect(Target, Columns("A")) '<-- change "Columns("A") to a named range with your cities
End Sub
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
If lastCell Is Nothing Then Exit Sub '<--| no action if lastCell has not been properly set by 'Worksheet_SelectionChange()'
If Target.Type = msoHyperlinkRange And Target.Range.Address = "$S$15" Then
Application.ScreenUpdating = False
Sheet15.Visible = True
Sheet15.ListObjects("Table17").Range.AutoFilter Field:=19, Criteria1:=lastCell.Value '<--| set the criteria as 'lastCell' value
Sheet15.Activate
Application.ScreenUpdating = True
End If
End Sub
as per comments, you change Columns("A") reference in Worksheet_SelectionChange() to your actual range with cities names (perhaps a named range)
Note: unless the hyperlink points to itself, ActiveCell.Value will be the value at the link destination: use Target.Range.Value if you want the value from the cell containing the link.
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
If Target.Type = msoHyperlinkRange And Target.Range.Address = "$S$15" Then
Application.ScreenUpdating = False
With Sheet15
.Visible = True
.ListObjects("Table17").Range.AutoFilter Field:=19, _
Criteria1:=Target.Range.Value
.Activate
End With
Application.ScreenUpdating = True
End If
End Sub

VBA code not activating cell

Looks like something wrong with my code. But, I am not able to figure the problem.
I have 2 tabs on workbook. Main sheet and Sub Sheet.
Selecting "yes" in the drop-down on main sheet will enable Sub sheet for entry.
Selecting "No" in the drop-down on main sheet will disable cells on Sub-sheet.
My problem : When I select "No", I dont see the "Active Cell" on any of the sheets. What I mean by Active Cell is the green border we get when we click on cell(Screenshot attached).
Code on Main Sheet
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Intersect(Target, Range("R12")) Is Nothing Then
If Target.Value = "YES" Then
Call Enabler
Else
Call Disabler
End If
End If
Application.EnableEvents = True
End Sub
Code on Modules
Public Sub Disabler()
With ThisWorkbook.Sheets("SubSheet")
.Unprotect Password:="xyz"
.Range("E13:E14").Locked = True
.Protect Password:="xyz"
End With
End Sub
Public Sub Enabler()
With ThisWorkbook.Sheets("SubSheet")
.Unprotect Password:="xyz"
.Range("E13:E14").Locked = False
.Protect Password:="xyz"
End With
End Sub
Something like the following should work for you...
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ExitSub
Application.EnableEvents = False
If Target.Address <> "$R$12" Then Exit Sub
If Target.Value = "YES" Then
Call LockRange(False)
Else
Call LockRange(True)
End If
ExitSub:
Application.EnableEvents = True
End Sub
Private Function LockRange(bFlag As Boolean) As Boolean
On Error Resume Next
With ThisWorkbook.Sheets("SubSheet")
.Unprotect Password:="xyz"
.Range("E13:E14").Locked = bFlag
.Protect Password:="xyz"
'Debug.Print bFlag
End With
LockRange = True
End Function
I guess you have to type in:
.EnableSelection = xlNoRestrictions
BTW you may want to shorten your code by merging Disabler() and Enabler() subs into one Sub:
Public Sub DisableSubSheet(disable As Boolean)
With ThisWorkbook.Worksheets("SubSheet")
.Unprotect Password:="xyz"
.Range("E13:E14").Locked = disable
.Protect Password:="xyz"
.EnableSelection = xlNoRestrictions '<--| make it possible for user to select cells
End With
End Sub
thus, changing your Worksheet_Change event handler code as follows:
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Intersect(Target, Range("R12")) Is Nothing Then
If Target.Value = "YES" Then
DisableSubSheet False '<--| in place of previous 'Call Enabler'
Else
DisableSubSheet True '<--| in place of previous 'Call Disabler'
End If
End If
Application.EnableEvents = True
End Sub

VBa Code not coming out of loop

Question looks big but answer for you guys will be simple
I have code that works for first time and not working for second attempt.
I have 2 sheets "Menu" and "Subsheet"
Basically, i have data validation drop-down set on Menu Sheet yes/no values.
First scenario
Selecting "Yes" will enable the cells on second sheet (Subsheet)
Selecting "No" will disable cells on second sheet(Subsheet).
Second scenario,
User selecting "no" and selecting second sheet will throw a prompt for him to enable cells "ok" and cancel.
Select "ok" will enable cells and value in dropdown will be changed to "yes"
selecting "cancel" in msgprompt will disable cells and value in dropdown will remain "no"
Msg prompt should not be displayed, if user has selected "yes" in dropdown..
Question:Code works fine, until it comes to second scenario.
User selects "No" and selects second sheet in the message prompt, he selects "no". Now cells are disabled.
If user comes back to Menu Sheet and selects "Yes", will not enable cells.
Not sure what is it not enabling cells now. Please help
Code on Menu Sheet
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A11")) Is Nothing Then Exit Sub
Application.EnableEvents = False
Select Case (Target.Value)
Case "YES"
Call uEnable
Case "NO"
Call uDisable
Exit Sub
End Select
Application.EnableEvents = True
End Sub
Code on SubSheet
Private Sub Worksheet_Activate()
UDisable
End Sub
Code on Module
Option Explicit
Private mMessageDisplayed As Boolean
Public Sub uDisable()
If ActiveSheet.ProtectContents And Not mMessageDisplayed Then
mMessageDisplayed = True
If ThisWorkbook.Sheets("Menu").Range("A11") = "NO" Then
If MsgBox("Cells are locked on current sheet, press ok to Unlock", vbOKCancel + vbInformation) = vbOK Then
ThisWorkbook.Worksheets("Menu").Range("A11") = "YES"
With ThisWorkbook.Sheets("Subsheet")
ActiveWorkbook.Unprotect Password:="xyz"
.Range("E13:E14").Locked = False
ActiveWorkbook.Unprotect Password:="xyz"
End With
Else
ThisWorkbook.Worksheets("Menu").Range("A11") = "NO"
With ThisWorkbook.Sheets("Subsheet")
ActiveWorkbook.Unprotect Password:="xyz"
.Range("E13:E14").Locked = True
ActiveWorkbook.Protect Password:="xyz"
End With
End If
Else
Exit Sub
End If
End If
End Sub
Second module
Public Sub uEnable()
With ThisWorkbook.Sheets("Subsheet")
ActiveWorkbook.Unprotect Password:="xyz"
.Range("E13:E14").Locked = False
ActiveWorkbook.Protect Password:="xyz"
End With
End Sub
I tried to use debug method, couldn't identify the root cause.
Two intersect codes
`Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("E42")) Is Nothing Then Exit Sub
Application.EnableEvents = False
Dim inputCell As Range
Set inputCell = Range("E43")
Select Case (Target.Value)
Case "Specific Days"
inputCell.Locked = False
inputCell.Activate
Case Else
'This handles **ANY** other value in the dropdown
inputCell.Locked = True
' inputCell.Clear
End Select
Application.EnableEvents = True
If Intersect(Target, Range("E29")) Is Nothing Then Exit Sub
Application.EnableEvents = False
Select Case (Target.Value)
Case "YES"
Call Notify
Case "NO"
Call NotifyUserGeneral
End Select
Application.EnableEvents = True
End Sub`
Remove the Exit Sub from underneath Call uDisable. Otherwise Application.EnableEvents = True never gets called...
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A1")) Is Nothing Then Exit Sub
Application.EnableEvents = False
Select Case (Target.Value)
Case "YES"
Call uEnable
Case "NO"
Call uDisable
'Exit Sub <---Can't do this.
End Select
Application.EnableEvents = True
End Sub
...and there isn't any other code that will turn them back on. You can't rely on an event handler to set Application.EnableEvents = True after you've turned off event handling.

Can I have more than one event code under "this Workbook"

I have these 2 codes:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Application.ScreenUpdating = False
For Each Value In Target.Columns
Columns(Value.Column).ColumnWidth = 8.43
Worksheets(Sh.Name).Columns(Value.Column).AutoFit
Next Value
Application.ScreenUpdating = True
End Sub
and
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Application.EnableEvents = False
If Not Target.Cells.Count = 1 Or Target.Row = 1 Then Exit Sub
If Target.Offset(1, 0) = "" Then
Target.Offset(-1, 0).Copy
Target.PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
End If
Application.EnableEvents = True
End Sub
This two pieces of code work fine but the thing is I can't make them work together these 2 codes should be place under "This Workbook" object in excel so I've been trying to come up with a way for this to work I do understand that you should only have one event code in a workbook but that there is a "workaround" it someone suggested the following:
Private Sub Worksheet_Change(ByVal Target As Range)
Call Macro1(Target)
Call Macro2(Target)
End Sub
Sub Macro1(ByVal Target As Range)
If Target.Column = 1 And Target.Offset(1, 0) = "" Then
Target.Offset(-1, 0).Copy
Target.PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
End If
End Sub
Sub Macro2(ByVal Target As Range)
Application.ScreenUpdating = False
For Each Value In Target.Columns
Columns(Value.Column).ColumnWidth = 8.43
Worksheets(Sh.Name).Columns(Value.Column).AutoFit
Next Value
Application.ScreenUpdating = True
End Sub
But it does not work none of the event are triggered so as I type nothing happens, I thought at first it would be impossible but when someone suggested this at first it made sense but it doesn't work but still I saw a shred of hope which I want to hang on tight to but since I don't know who to make it work.
Is it possible to have these 2 codes working on the same workbook?
These events need to be under the Sheet object, not the workbook. Note that from the dropdown, when you are in the "thisWorkbook" code section, there is no "Change" event. You'll also need to name the function Private Sub Worksheet_Change(ByVal Target As Range)
So far I've tried this and for now its working
Private Sub Worksheet_Change(ByVal Target As Range)
Call Macro1(Target)
Call Macro2(Target)
End Sub
Sub Macro1(ByVal Target As Range)
Application.EnableEvents = False
If Not Target.Cells.Count = 1 Or Target.Row = 1 Then Exit Sub
If Target.Offset(1, 0) = "" Then
Target.Offset(-1, 0).Copy
Target.PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
End If
Application.EnableEvents = True
End Sub
Sub Macro2(ByVal Target As Range)
Application.ScreenUpdating = False
For Each Value In Target.Columns
Columns(Value.Column).ColumnWidth = 8.43
ActiveSheet.Columns(Value.Column).AutoFit
Next Value
Application.ScreenUpdating = True
End Sub