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.
Related
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
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'm working on an VBA-Code right now, which should:
let you select a text from a dropdown-list
select multiple text and put it on the next line
let you edit the values of the cell.
The Problem here is that when I disable the Error message - so I can edit the cell, the values from the target cell get added to the cell.
So for example I want to edit B to C in the Dropdown cell.
Instead I get A B A C
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim wert_old As String
Dim wertnew As String
On Error GoTo Errorhandling
If Not Application.Intersect(Target, Range("A6")) Is Nothing Then
Set rngDV = Target.SpecialCells(xlCellTypeAllValidation)
If rngDV Is Nothing Then GoTo Errorhandling
If Not Application.Intersect(Target, rngDV) Is Nothing Then
Application.EnableEvents = False
wertnew = Target.Value
Application.Undo
wertold = Target.Value
Target.Value = wertnew
If wertold <> "" Then
If wertnew <> "" Then
Target.Value = wertold & vbCrLf & wertnew
End If
End If
End If
Application.EnableEvents = True
End If
Errorhandling:
Application.EnableEvents = True
End Sub
You must use vbLf as linebreak in cells instead of vbCrLf
Use Option Explicit to prevent using wrong variable names. You declared wert_old but you used wertold. This will easily mess up and drive you nuts. I recommend always to activate Option Explicit: In the VBA editor go to Tools › Options › Require Variable Declaration.
As a workaround you can run your code only if it doesn't contain a vbLf by using
InStr(1, Target.Value, vbLf) < 1
Note that this workaround will make you able to edit the cell if there is more than one item in it but if you try to edit if it only contains one item it will still add it (I have no workaround for that).
So you end up with something like:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Errorhandling
If Not Application.Intersect(Target, Me.Range("A6")) Is Nothing Then
Dim rngDV As Range
Set rngDV = Target.SpecialCells(xlCellTypeAllValidation)
If rngDV Is Nothing Then GoTo Errorhandling
If Not Application.Intersect(Target, rngDV) Is Nothing And InStr(1, Target.Value, vbLf) < 1 Then
Application.EnableEvents = False
Dim WertNew As String
WertNew = Target.Value
Application.Undo
Dim WertOld As String
WertOld = Target.Value
Target.Value = WertNew
If WertOld <> vbNullString Then
If WertNew <> vbNullString Then
Target.Value = WertOld & vbLf & WertNew
End If
End If
End If
Application.EnableEvents = True
End If
Errorhandling:
Application.EnableEvents = True
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