I have a spreadsheet where I have adapted two pieces of VBA code to perform two different double click event actions.
The 1st piece of code enters a "✓" in a specific range of cells when double clicked and removes it when double clicked again:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("H2:H600,M2:V600")) Is Nothing Then
Application.EnableEvents = False
If ActiveCell.Value = ChrW(&H2713) Then
ActiveCell.ClearContents
Else
ActiveCell.Value = ChrW(&H2713)
End If
Cancel = True
End If
Application.EnableEvents = True
End Sub
The 2nd piece of code enters a date/time stamp in a range of cells when double clicked:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'Coded by SunnyKow - 16/09/2016
Application.EnableEvents = False
On Error GoTo ErrorRoutine
'You can change the range here
If Not Intersect(Target, Range("L2:L600,Y2:Y600")) Is Nothing Then
'Update only if cell is empty
If Target = "" Then
Target = Now
End If
Cancel = True
End If
Application.EnableEvents = True
Exit Sub
ErrorRoutine:
Application.EnableEvents = True
End Sub
Because you cannot have two double click events in single worksheet (as separate VBA code), how do I merge these two pieces of VBA so that it is a single piece of code with two distinct actions based on the cell range selected. Would appreciate any help to resolve this.
It looks like an if statement will do the trick
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Application.EnableEvents = False
On Error GoTo ErrorRoutine
If Not Intersect(Target, Range("L2:L600,Y2:Y600")) Is Nothing Then
'Update only if cell is empty
If Target = "" Then
Target = Now
End If
Cancel = True
ElseIf Not Intersect(Target, Range("H2:H600,M2:V600")) Is Nothing Then
Application.EnableEvents = False
If ActiveCell.Value = ChrW(&H2713) Then
ActiveCell.ClearContents
Else
ActiveCell.Value = ChrW(&H2713)
End If
Cancel = True
End If
Application.EnableEvents = True
Exit Sub
ErrorRoutine:
Application.EnableEvents = True
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Application.EnableEvents = False
On Error GoTo ErrorRoutine
If Not Intersect(Target, Range("L2:L600,Y2:Y600")) Is Nothing Then
If Target = "" Then
Target = Now
End If
Cancel = True
ElseIf Not Intersect(Target, Range("M2:V600")) Is Nothing Then
If ActiveCell.Value = ChrW(&H2713) Then
ActiveCell.ClearContents
Else
ActiveCell.Value = ChrW(&H2713)
End If
Cancel = True
ElseIf Not Intersect(Target, Range("H2:H600")) Is Nothing Then
If ActiveCell.Value = ChrW(&H2713) Then
ActiveCell.ClearContents
Else
ActiveCell.Value = ChrW(&H2713)
Target.Offset(0, 18) = Now
End If
Cancel = True
End If
Application.EnableEvents = True
Exit Sub
ErrorRoutine:
Application.EnableEvents = True
End Sub
Related
I haven't used VBA before so I'm really new to this :-) The below is the code I am currently using , and simply need to lock all area's of the sheet (with out using the sheet name) apart from A13:A377, B1, D3:D4, D13:D377, F13:I377. I can't protect the sheet because the VBA won't work. Help please...
Private Sub Worksheet_Change(ByVal Target As Range)
' To allow multiple selections in a Drop Down List in Excel (without repetition)
Dim Oldvalue As String
Dim Newvalue As String
Application.EnableEvents = True
On Error GoTo Exitsub
If Target.Column = 1 Then
If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
GoTo Exitsub
Else: If Target.Value = "" Then GoTo Exitsub Else
Application.EnableEvents = False
Newvalue = Target.Value
Application.Undo
Oldvalue = Target.Value
If Oldvalue = "" Then
Target.Value = Newvalue
Else
If InStr(1, Oldvalue, Newvalue) = 0 Then
Target.Value = Oldvalue & " & " & Newvalue
Else:
Target.Value = Oldvalue
End If
End If
End If
End If
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
End Sub
unlock cells and protect sheet
I don't see any relation between your description and the code you have shared! Please find below a proposal to unlock a union of cells and protect the sheet (without password!)
Option Explicit
Sub UnlockCells_and_Protect()
Dim actSheet As String
actSheet = "Sheet2" ' choose whatever you need
'actSheet = ActiveSheet.Name
'actSheet = Sheets(3).Name
'actsheet = "SpecialSheet"
Call UnprotectSheet(actSheet)
Call LockAll(actSheet)
Call UnlockRange(actSheet, "A13:A377,B1,D3:D4,D13:D377,F13:I377")
Call ProtectSheet(actSheet)
End Sub
Sub UnlockRange(sheetName As String, RangeReference As String)
With Sheets(sheetName).Range(RangeReference)
.Locked = False
.FormulaHidden = False
'you might want to mark the unlocked cells for debugging
Sheets(sheetName).Range(RangeReference).Interior.Color = vbYellow
End With
End Sub
Sub ProtectSheet(sheetName As String)
Sheets(sheetName).Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
Sub ProtectActiveSheet()
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
Sub UnprotectSheet(sheetName As String)
Sheets(sheetName).Unprotect
End Sub
Sub UnprotectActiveSheet()
ActiveSheet.Unprotect
End Sub
Sub LockAll(sheetName As String)
Sheets(sheetName).Cells.Locked = True
Sheets(sheetName).Cells.FormulaHidden = False
'if you marked the unlocked cells yellow you change
'them back to white with lock/unlock all
Sheets(sheetName).Cells.Interior.Color = vbWhite
End Sub
Sub UnlockAll(sheetName As String)
Sheets(sheetName).Cells.Locked = False
Sheets(sheetName).Selection.FormulaHidden = False
'if you marked the unlocked cells yellow you change
'them back to white with lock/unlock all
Sheets(sheetName).Cells.Interior.Color = vbWhite
End Sub
I am using the below codes to change the "Sheet2" "D2" value as per the value in "Sheet1" "B2" and VICE VERSA too. But they are not working together. If I use them separately then both coding is working perfectly. How can I correct them to perform together?
"Sheet1"
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B2")) Is Nothing Then
Select Case Target.Value
Case Is = "Included": Worksheets("Sheet2").Range("D2") = Target.Value
Case Is = "Excluded": Worksheets("Sheet2").Range("D2") = Target.Value
End Select
End If
End Sub
"Sheet2"
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("D2")) Is Nothing Then
Select Case Target.Value
Case Is = "Included": Worksheets("Sheet1").Range("B2") = Target.Value
Case Is = "Excluded": Worksheets("Sheet1").Range("B2") = Target.Value
End Select
End If
End Sub
From comments above:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, v
Set rng = Intersect(Target, Me.Range("B2"))
If Not rng Is Nothing Then
v = Target.Value
If v = "Included" Or v = "Excluded" Then
On Error GoTo haveError 'set up error handling
Application.EnableEvents = False 'disable events
ThisWorkbook.Worksheets("Sheet2").Range("D2") = v
Application.EnableEvents = True 're-enable events
End If
End If
Exit Sub 'normal exit
haveError:
Application.EnableEvents = True 'make sure events not left turned off
End Sub
I know this question has been asked a few times. I want to increase the font size of a drop down list in Excel. I can get it going without any other code in the sheet but I've got a separate sub that hides/unhides specific columns based off values entered into Column B. I'm struggling to combine both functions into the same working sheet.
This is my attempt:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:A")) Is Nothing Then
On Error GoTo safe_exit
Application.EnableEvents = False
Dim t As Range
For Each t In Intersect(Target, Range("A:A"))
Select Case (t.Value)
Case "X"
Columns("B:C").EntireColumn.Hidden = False
Columns("D:E").EntireColumn.Hidden = True
Case "Y"
Columns("D:E").EntireColumn.Hidden = False
Columns("B:C").EntireColumn.Hidden = True
'do nothing
End Select
Next t
End If
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("A:A")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
ActiveWindow.Zoom = 100
End If
safe_exit:
Application.EnableEvents = True
End Sub
You only need to add the one line from your second sub to the first:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:A")) Is Nothing Then
On Error GoTo safe_exit
Application.EnableEvents = False
Dim t As Range
For Each t In Intersect(Target, Range("A:A"))
Select Case (t.Value)
Case "X"
Columns("B:C").EntireColumn.Hidden = False
Columns("D:E").EntireColumn.Hidden = True
Case "Y"
Columns("D:E").EntireColumn.Hidden = False
Columns("B:C").EntireColumn.Hidden = True
'do nothing
End Select
Next t
ActiveWindow.Zoom = 100 '<<<
End If
safe_exit:
Application.EnableEvents = True
End Sub
I use the below VBA code to display a checkmark/tick when a cell is double clicked. At times, the checkmark/tick needs to be removed. To remove the checkmark/tick, the cell needs to be double clicked again. Once double clicked to remove the checkmark/tick, the cell return as blank. My question is; would it be possible to display the word ‘YES’ rather than having the cell blank?
Or as an even better option, is it possible to return the original text (before the cell was even double clicked) in the cell when double clicked (to remove checkmark/tick) rather than return as blank?
I hope this makes sense! Thank you in advance!
Below is the VBA code I have used for the checkmark/tick:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error GoTo 1
If Not Intersect(Target, Range("A2:Z200")) Is Nothing Then
Application.EnableEvents = False
If Target.Value = ChrW(&H2713) Then
Target.ClearContents
Cancel = True
Else
Target.Value = ChrW(&H2713)
Cancel = True
End If
End If
On Error GoTo 0
1 Application.EnableEvents = True
End Sub
To display the word "YES" change the line :
Target.ClearContents
With:
Target.Value = "YES"
Full Code
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
On Error GoTo 1
If Not Intersect(Target, Range("A2:Z200")) Is Nothing Then
Application.EnableEvents = False
If Target.Value = ChrW(&H2713) Then
Target.Value = "YES"
Else
Target.Value = ChrW(&H2713)
End If
Cancel = True
End If
On Error GoTo 0
1 Application.EnableEvents = True
End Sub
This will replace the original value with a checkmark and then restore the original value on re-clicking, but it only works for text values and only changes the appearance of the cell...
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("A2:Z200")) Is Nothing Then
On Error GoTo haveError
Application.EnableEvents = False
If Target.NumberFormat Like ";;;*" Then
Target.NumberFormat = "General"
Else
Target.NumberFormat = ";;;" & ChrW(&H2713)
End If
Cancel = True
End If
haveError:
Application.EnableEvents = True
End Sub
Why this code not work?
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
If Not Intersect(Target, Columns(1)) Is Nothing Then
If Len(Target.Value) <> 14 Then
Target.Value = Format(Now(), ["yyyymmddhhmmss"])
Target.NumberFormat = "0"
Else
With Application
.EnableEvents = False
.Undo
.EnableEvents = True
End With
End If
End If
If Not Intersect(Target, Columns(18)) Is Nothing Then
If Len(Target.Value) <> 10 Then
Target.Value = Format(Date, ["yyyy.mm.dd"])
Else
With Application
.EnableEvents = False
.Undo
.EnableEvents = True
End With
End If
End If
End Sub
I need to change value in cell if it not already set (I check for string len), so if value is set I need to prevent this value from changes by this macros and let changing only manually.
How to do that?
Start by using Application.EnableEvents = False before changing any values and then Application.EnableEvents = True before exiting. By changing the value(s), you are triggering another event that runs on top of the original and may attempt to undo what you started.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
Application.EnableEvents = False
If Not Intersect(Target, Union(Columns(1), Columns(18))) Is Nothing Then
Dim tmp As Variant
tmp = Target.Value
Application.Undo
If Not Intersect(Target, Columns(1)) Is Nothing Then
If Len(Target.Value) <> 14 Then
Target.Value = Format(Now(), ["yyyymmddhhmmss"])
End If
ElseIf Not Intersect(Target, Columns(18)) Is Nothing Then
If Len(Target.Value) <> 10 Then
Target.Value = Format(Date, ["yyyy.mm.dd"])
End If
End If
End If
Application.EnableEvents = True
End Sub
The other hole in your logic was checking the current Target value's length. You needed to undo first to see what the value was before something new was typed in.