I have a listbox that opens when I double-click the cell. When I select multiple items in the listbox and hit okay it will put these items in the cell. BUT if I want to go to the cell afterwards (select cell and hit F2) and modify the entry it will add my modification but also duplicate what the listbox put in there before. I just want the modification. How can I stop the duplication?
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim lType As Long
Dim strList As String
Application.EnableEvents = False
On Error Resume Next
lType = Target.Validation.Type
On Error GoTo exitHandler
If lType = 3 Then
Cancel = True
strList = Target.Validation.Formula1
strList = Right(strList, Len(strList) - 1)
strDVList = strList
frmDVList.Show
End If
exitHandler:
Application.EnableEvents = True
End Sub
----------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim strSep As String
strSep = "; "
Application.EnableEvents = False
On Error Resume Next
If Target.Count > 1 Then GoTo exitHandler
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler
If rngDV Is Nothing Then GoTo exitHandler
If Intersect(Target, rngDV) Is Nothing Then
Else
newVal = Target.Value
Application.Undo
oldVal = Target.Value
Target.Value = newVal
If newVal = "" Then
Else
If oldVal = "" Then
Target.Value = newVal
Else
Target.Value = oldVal & strSep & newVal
End If
End If
End If
exitHandler:
Application.EnableEvents = True
End Sub
Related
I have the following code which works to an extent with data validation on a predefined list on aa separate sheet. The issue I am having is that the drop down list lets me select an item more than once. However, I want to be able to select an Item only once.
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
'do nothing
Else
Application.EnableEvents = False
newVal = Target.Value
Application.Undo
oldVal = Target.Value
Target.Value = newVal
If oldVal = "" Then
'do nothing
Else
If newVal = "" Then
'do nothing
Else
Target.Value = oldVal _
& ", " & newVal
End If
End If
End If
exitHandler:
Application.EnableEvents = True
End Sub
I am trying to combine the following macros:
Multiple selection in a drop down list
Autofit merged cells
Hide/unhide rows in a form
Macros work individually but they should all be added in the same specific worksheet and I cannot figure out how to combine them. Any help is appreciated. Thanks!
1)
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Oldvalue As String
Dim Newvalue As String
On Error GoTo Exitsub
If Target.Address = "$F$8" Or Target.Address = "$F$9" 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
Target.Value = Oldvalue & ", " & Newvalue
End If
End If
End If
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim NewRwHt As Single
Dim cWdth As Single, MrgeWdth As Single
Dim c As Range, cc As Range
Dim ma As Range
With Target
If .MergeCells And .WrapText Then
Set c = Target.Cells(1, 1)
cWdth = c.ColumnWidth
Set ma = c.MergeArea
For Each cc In ma.Cells
MrgeWdth = MrgeWdth + cc.ColumnWidth
Next
Application.ScreenUpdating = False
ma.MergeCells = False
c.ColumnWidth = MrgeWdth
c.entirerow.AutoFit
NewRwHt = c.RowHeight
c.ColumnWidth = cWdth
ma.MergeCells = True
ma.RowHeight = NewRwHt
cWdth = 0: MrgeWdth = 0
Application.ScreenUpdating = True
End If
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Where As Range, Area As Range, This As Range, Here As Range
Dim First As Boolean
Dim i As Long
Application.ScreenUpdating = False
Set Where = FindAll(Me.Columns("H"), "Section")
For Each Area In Where.Cells
If Area.MergeCells Then Set Area = Area.MergeArea
First = True
For Each This In Area.Cells
Set Here = Intersect(Range("A:G"), This.EntireRow)
i = WorksheetFunction.CountBlank(Here)
This.EntireRow.Hidden = (i = Here.Columns.Count) And Not First
First = i <> Here.Columns.Count
Next
Next
Application.ScreenUpdating = True
End Sub
Combine Worksheet Change Event Codes
The Code
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
MultipleSelection Target
AutofitMerge Target
HideUnhide Me
End Sub
Private Sub MultipleSelection(ByVal Target As Range)
Dim Oldvalue As String
Dim Newvalue As String
On Error GoTo Exitsub
If Target.Address = "$F$8" Or Target.Address = "$F$9" 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
Target.Value = Oldvalue & ", " & Newvalue
End If
End If
End If
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
End Sub
Private Sub AutofitMerge(ByVal Target As Range)
Dim NewRwHt As Single
Dim cWdth As Single, MrgeWdth As Single
Dim c As Range, cc As Range
Dim ma As Range
With Target
If .MergeCells And .WrapText Then
Set c = Target.Cells(1, 1)
cWdth = c.ColumnWidth
Set ma = c.MergeArea
For Each cc In ma.Cells
MrgeWdth = MrgeWdth + cc.ColumnWidth
Next
Application.ScreenUpdating = False
ma.MergeCells = False
c.ColumnWidth = MrgeWdth
c.EntireRow.AutoFit
NewRwHt = c.RowHeight
c.ColumnWidth = cWdth
ma.MergeCells = True
ma.RowHeight = NewRwHt
cWdth = 0: MrgeWdth = 0
Application.ScreenUpdating = True
End If
End With
End Sub
Private Sub HideUnhide(ByVal ws As Worksheet)
Dim Where As Range, Area As Range, This As Range, Here As Range
Dim First As Boolean
Dim i As Long
Application.ScreenUpdating = False
Set Where = FindAll(ws.Columns("H"), "Section")
For Each Area In Where.Cells
If Area.MergeCells Then Set Area = Area.MergeArea
First = True
For Each This In Area.Cells
Set Here = Intersect(Range("A:G"), This.EntireRow)
i = WorksheetFunction.CountBlank(Here)
This.EntireRow.Hidden = (i = Here.Columns.Count) And Not First
First = i <> Here.Columns.Count
Next
Next
Application.ScreenUpdating = True
End Sub
I'm trying to have a pop up option come up where a user can select from a list and that is inputted into a cell and the values are separated by commas. I got my VBA code to function but I only want this to be tied to a specific cell ranges rather than the data validation list in basically any cell range.
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim strList As String
On Error Resume Next
Application.EnableEvents = False
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler
If rngDV Is Nothing Then GoTo exitHandler
If Not Intersect(Target, rngDV) Is Nothing Then
If Target.Validation.Type = 3 Then
strList = Target.Validation.Formula1
strList = Right(strList, Len(strList) - 1)
strDVList = strList
frmDVList.Show
End If
End If
exitHandler:
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim strSep As String
strSep = ", "
Application.EnableEvents = False
On Error Resume Next
If Target.Count > 1 Then GoTo exitHandler
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
newVal = Target.Value
Application.Undo
oldVal = Target.Value
Target.Value = newVal
If newVal = "" Then
'do nothing
Else
If oldVal = "" Then
Target.Value = newVal
Else
Target.Value = oldVal & strSep & newVal
End If
End If
End If
exitHandler:
Application.EnableEvents = True
End Sub
I think I need to update the Private Sub Worksheet_SelectionChange(ByVal Target As Range) but when I select a cell range like G1:G100, it causes debug issue.
Also, how can I have the data validation list always show up in Column 'G'?
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
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