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
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 use a worksheet to help keep track of inventory numbers in a warehouse. I am trying to add a time stamp so I can see when I last edited a cell. I already have some VBA macros and get an ambiguous name error when I try to add the code for the time stamp.
This is the code I already have:
Dim xRg As Range
Dim xChangeRg As Range
Dim xDependRg As Range
Dim xDic As New Dictionary
Private Sub Worksheet_Change(ByVal Target As Range)
Dim I As Long
Dim xCell As Range
Dim xDCell As Range
Dim xHeader As String
Dim xCommText As String
On Error Resume Next
Application.ScreenUpdating = False
Application.EnableEvents = False
xHeader = "Previous value :"
x = xDic.Keys
For I = 0 To UBound(xDic.Keys)
Set xCell = Range(xDic.Keys(I))
Set xDCell = Cells(xCell.Row, 9)
xDCell.Value = ""
xDCell.Value = xDic.Items(I)
Next
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim I, J As Long
Dim xRgArea As Range
On Error GoTo Label1
If Target.Count > 1 Then Exit Sub
Application.EnableEvents = False
Set xDependRg = Target.Dependents
If xDependRg Is Nothing Then GoTo Label1
If Not xDependRg Is Nothing Then
Set xDependRg = Intersect(xDependRg, Range("H:H"))
End If
Label1:
Set xRg = Intersect(Target, Range("G:G"))
If (Not xRg Is Nothing) And (Not xDependRg Is Nothing) Then
Set xChangeRg = Union(xRg, xDependRg)
ElseIf (xRg Is Nothing) And (Not xDependRg Is Nothing) Then
Set xChangeRg = xDependRg
ElseIf (Not xRg Is Nothing) And (xDependRg Is Nothing) Then
Set xChangeRg = xRg
Else
Application.EnableEvents = True
Exit Sub
End If
xDic.RemoveAll
For I = 1 To xChangeRg.Areas.Count
Set xRgArea = xChangeRg.Areas(I)
For J = 1 To xRgArea.Count
xDic.Add xRgArea(J).Address, xRgArea(J).Value
Next
Next
Set xChangeRg = Nothing
Set xRg = Nothing
Set xDependRg = Nothing
Application.EnableEvents = True
End Sub
This is the code I tried to add:
Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 20180830
Dim xCellColumn As Integer
Dim xTimeColumn As Integer
Dim xRow, xCol As Integer
Dim xDPRg, xRg As Range
xCellColumn = 10
xTimeColumn = 13
xRow = Target.Row
xCol = Target.Column
If Target.Text <> "" Then
If xCol = xCellColumn Then
Cells(xRow, xTimeColumn) = Now()
Else
On Error Resume Next
Set xDPRg = Target.Dependents
For Each xRg In xDPRg
If xRg.Column = xCellColumn Then
Cells(xRg.Row, xTimeColumn) = Now()
End If
Next
End If
End If
End Sub
Instead of:
Private Sub Worksheet_Change(ByVal Target As Range)
'first set of code
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
'second set of code
End Sub
which as you've found won't compile, you'd have something like
Private Sub Worksheet_Change(ByVal Target As Range)
FirstHandler Target
SecondHandler Target
End Sub
'next 2 subs have your original code
Private Sub FirstHandler(ByVal Target As Range)
'first set of code
End Sub
Private Sub SecondHandler(ByVal Target As Range)
'second set of code
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 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
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