I'm using a VBA code (that I found online, I'm not very good at VBA) to select multiple items from a drop down list. However I'd like for one of the cells in my Workbook (cell $D$3) to not be affected by this macro. So while it has data validation, you could only select one option. Any help appreciated, I'm trying to learn!
Here's the code I used
Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 2019/11/13
Dim xRng As Range
Dim xValue1 As String
Dim xValue2 As String
If Target.Count > 1 Then Exit Sub
On Error Resume Next
Set xRng = Cells.SpecialCells(xlCellTypeAllValidation)
If xRng Is Nothing Then Exit Sub
Application.EnableEvents = False
If Not Application.Intersect(Target, xRng) Is Nothing Then
xValue2 = Target.Value
Application.Undo
xValue1 = Target.Value
Target.Value = xValue2
If xValue1 <> "" Then
If xValue2 <> "" Then
If xValue1 = xValue2 Or _
InStr(1, xValue1, ", " & xValue2) Or _
InStr(1, xValue1, xValue2 & ",") Then
Target.Value = xValue1
Else
Target.Value = xValue1 & ", " & xValue2
End If
End If
End If
End If
Application.EnableEvents = True
End Sub
BigBen commented an answer which solved my problem, thank you!
Here is the revised version which has worked for me:
Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 2019/11/13
Dim xRng As Range
Dim xValue1 As String
Dim xValue2 As String
If Target.Count > 1 Then Exit Sub
On Error Resume Next
If Not Intersect(Target, Me.Range("D3")) Is Nothing Then Exit Sub
Set xRng = Cells.SpecialCells(xlCellTypeAllValidation)
If xRng Is Nothing Then Exit Sub
Application.EnableEvents = False
If Not Application.Intersect(Target, xRng) Is Nothing Then
xValue2 = Target.Value
Application.Undo
xValue1 = Target.Value
Target.Value = xValue2
If xValue1 <> "" Then
If xValue2 <> "" Then
If xValue1 = xValue2 Or _
InStr(1, xValue1, ", " & xValue2) Or _
InStr(1, xValue1, xValue2 & ",") Then
Target.Value = xValue1
Related
Fairly new to VBA and Macros, and I would need assistance in combining these 2 worksheet events. Both work individually and I haven't found a way to combine them to run.
Macro 1: Automatically updating Timestamp Data Entries
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myTableRange As Range
Dim myDateTimeRange As Range
Dim myUpdatedRange As Range
Set myTableRange = Range("W4:W3000")
If Intersect(Target, myTableRange) Is Nothing Then Exit Sub
Application.EnableEvents = False
Set myDateTimeRange = Range("AF" & Target.Row)
Set myUpdatedRange = Range("AG" & Target.Row)
If myDateTimeRange.Value = "" Then
myDateTimeRange.Value = Now
End If
myUpdatedRange.Value = Now
Application.EnableEvents = True
End Sub
Macro 2: Allowing for multiple selection in Dropdown lists
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xRng As Range
Dim xValue1 As String
Dim xValue2 As String
If Target.Count > 1 Then Exit Sub
On Error Resume Next
Set xRng = Cells.SpecialCells(xlCellTypeAllValidation)
If xRng Is Nothing Then Exit Sub
Application.EnableEvents = False
If Not Application.Intersect(Target, xRng) Is Nothing Then
xValue2 = Target.Value
Application.Undo
xValue1 = Target.Value
Target.Value = xValue2
If xValue1 <> "" Then
If xValue2 <> "" Then
If xValue1 = xValue2 Or _
InStr(1, xValue1, "; " & xValue2) Or _
InStr(1, xValue1, xValue2 & ";") Then
Target.Value = xValue1
Else
Target.Value = xValue1 & "; " & xValue2
End If
End If
End If
End If
Application.EnableEvents = True
End Sub
Any help/guidance would be greatly appreciated.
Thank you!
Create a module and add two subs there:
Option Explicit
Public Sub updateTimestampDataEntries(ByVal c As Range)
'put the code here - using c instead of target
End Sub
Public Sub allowMultipleSelectionDropdown(ByVal c As Range)
'put the code here - using c instead of target
End Sub
Then you can use these subs within your worksheet_events like this
Private Sub Worksheet_Change(ByVal Target As Range)
dim c as Range: set c = Target.Cells(1,1) 'only check the first cell
If Not Application.Intersect(c, rgMyTable) Is Nothing Then
updateTimestampDataEntries c
ElseIf not Application.Intersect(c, rgValidationLists) Is Nothing Then
allowMultipleSelectionDropdown c
End If
End Sub
Private Property Get rgMyTable() as Range
'put your code here
set rgMyTable = ...
End Property
Private Property Get rgValidationLists as range
'put your code here
set rgValidationLists = ...
End Property
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 have developed on my excel spreadsheet that multiple items can be selected in a drop down list using the following code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
If Target.Count > 1 Then GoTo exitHandler
On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler
If rngDV Is Nothing Then GoTo exitHandler
If Intersect(Target, rngDV) Is Nothing Then
Else
Application.EnableEvents = False
newVal = Target.Value
Application.Undo
oldVal = Target.Value
Target.Value = newVal
If oldVal = "" Then
Else
If newVal = "" Then
Else
Target.Value = oldVal _
& ", " & newVal
End If
End If
End If
exitHandler:
Application.EnableEvents = True
End Sub
But, I want to now validate the answers that the drop down list items can only be selected once. And preferably, if the user selects that item again, that is it then removed.
Any help would be greatly appreciated.
Try this:
Private Sub Worksheet_Change(ByVal Target As Range)
Const SEP As String = ", "
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim arr, m, v
If Target.Count > 1 Then GoTo exitHandler
On Error Resume Next
Set rngDV = Target.SpecialCells(xlCellTypeSameValidation)
On Error GoTo exitHandler
If rngDV Is Nothing Then Exit Sub
newVal = Target.Value
If Len(newVal) = 0 Then Exit Sub 'user has cleared the cell...
Application.EnableEvents = False
Application.Undo
oldVal = Target.Value
If oldVal <> "" Then
arr = Split(oldVal, SEP)
m = Application.Match(newVal, arr, 0)
If IsError(m) Then
newVal = oldVal & SEP & newVal
Else
arr(m - 1) = ""
newVal = ""
For Each v In arr
If Len(v) > 0 Then newVal = newVal & IIf(Len(newVal) > 0, SEP, "") & v
Next v
End If
Target.Value = newVal
Else
Target.Value = newVal 'EDIT
End If
exitHandler:
Application.EnableEvents = True
End Sub
I have a worksheet that contains a few columns with hundreds of values. I want cell A1 to say "Value Changed" as soon as any value changes in the worksheet. I tried to make some code like what you see below, but I couldn't think of how to capture the original value in the OriginalValue variable. How can I detect when the value in any cell changes from something that is different than the Target value?
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Value <> OriginalValue Then
Range("A1").Value = "Value Change"
End If
End Sub
Further to my comments see this. I have commented the code so you will not have a problem understanding it. But if you do then simply ask. :)
Dim PrevValue As Variant
Private Sub Worksheet_Change(ByVal Target As Range)
'~~> Check if more than 1 cell is changed
If Target.Cells.CountLarge > 1 Then Exit Sub
'~~> Check if the change didn't happen in A1
If Not Intersect(Target, Range("A1")) Is Nothing Then Exit Sub
On Error GoTo Whoa
Application.EnableEvents = False
'~~> Compare
If Target.Value <> PrevValue Then
Range("A1").Value = "Value of " & Target.Address & " changed from " & _
PrevValue & " to " & Target.Value
'~~> Store new value to previous value
PrevValue = Target.Value
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
PrevValue = Target.Value
End Sub
You can "temporarily UnDo" to retrieve the original value:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Where As String, Oldvalue As Variant, NewValue As Variant
Application.EnableEvents = False
Where = Target.Address
NewValue = Target.Value
Application.Undo
Oldvalue = Target.Value
Target.Value = NewValue
Application.EnableEvents = True
MsgBox Where & vbCrLf & Oldvalue & vbCrLf & NewValue
End Sub
This is only good for single cells.
Hi i need to get column of a cell with the text as ACTION.
My current code is as below.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim actionColName As String
If Target.Count > 1 Then GoTo exitHandler
On Error Resume Next
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler
If rngDV Is Nothing Then GoTo exitHandler
If Intersect(Target, rngDV) Is Nothing Then
'do nothing
Else
Application.EnableEvents = False
newVal = Target.Value
Application.Undo
oldVal = Target.Value
Target.Value = newVal
If Target.Column = 3 Then
If oldVal = "" Then
'do nothing
Else
If newVal = "" Then
'do nothing
Else
Target.Value = oldVal _
& "+ " & newVal
End If
End If
End If
End If
exitHandler:
Application.EnableEvents = True
End Sub
In the above code there is a condition as below
If Target.Column = 3 Then
Instead of hard coding the value with 3 i would like to apply this logic for the complete column which contains the value ACTION in one of its cell in that column.
Use a Find to determine the (first) column containing Action
Sub GetAction()
Dim rng1 As Range
Set rng1 = ActiveSheet.UsedRange.Find("Action", , xlValues, xlWhole)
If Not rng1 Is Nothing Then
MsgBox "Found in column " & rng1.Column
Else
MsgBox "Not found", vbCritical
End If
End Sub