Adding a timestamp to a worksheet that already has VBA macros - excel

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

Related

VBA Vlookup Crashing

My VBA Vlookup code is crashing Excel and takes forever to execute. I need the VBA code and not the formula in the cell.
Private Sub Worksheet_Change(ByVal Target As Range)
Call lookup
End Sub
Sub lookup()
Dim srchres As Variant
Dim srch As Variant
Set sh1 = ThisWorkbook.Sheets("Customer")
Set sh4 = ThisWorkbook.Sheets("Invoice")
On Error Resume Next
srchres = Application.WorksheetFunction.VLookup(sh4.Range("A11:C11"), _
sh1.Range("B2:H99999"), 5, False)
On Error GoTo 0
If (IsEmpty(srchres)) Then
sh4.Range("A12") = CVErr(xlErrNA)
Else
sh4.Range("A12:C12").Value = srchres
End If
On Error Resume Next
srch = Application.WorksheetFunction.VLookup(sh4.Range("A11:C11"), _
sh1.Range("B2:H99999"), 6, False)
On Error GoTo 0
If (IsEmpty(srch)) Then
sh4.Range("A13:C13") = CVErr(xlErrNA)
Else
sh4.Range("A13:C13").Value = srch
End If
End Sub
ThisWorkbook's code for creating a drop-down list
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MySheets As Variant
Dim srchres As Variant
Dim srch As Variant
Set sh1 = ThisWorkbook.Sheets("Customer")
Set sh4 = ThisWorkbook.Sheets("Invoice")
MySheets = Array("sh1", "sh4")
If IsNumeric(Application.match(Sh.Name, MySheets, 0)) Then
If Target.Address = "'sh4'!$A$11" Then
sh4.Range("A2:A9999").Cells(sh4.Range("A2:A9999").Rows.Count + 1, 1) = Target
End If
End If
End Sub

Private Sub Worksheet_Change combine two codes

I am trying to combine these two codes, the first one is to change the name of my worksheet when I change the value of the cell m3, and the second code is to block the cells after modifying the cells. I am new in VBA so I don't know how to combine them.
CODE 1
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$M$3" Then RenameSheet
End Sub
CODE 2
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xRg As Range
On Error Resume Next
Set xRg = Intersect(Range("F6"), Target)
If xRg Is Nothing Then Exit Sub
Target.Worksheet.Unprotect Password:="1234"
xRg.MergeArea.Locked = True
Target.Worksheet.Protect Password:="1234"
End Sub
Also sub renamesheet code is:
Sub RenameSheet()
Dim rs As Worksheet
For Each rs In Sheets
If rs.Name <> "MENU" And rs.Name <> "CAJA_CONTABILIDAD" Then
rs.Name = "Vale " & rs.Range("M3")
End If
Next rs
If Target.Address = "$M$3" Then RenameSheet
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$M$3" Then
RenameSheet
Exit Sub
End If
Dim xRg As Range
Set xRg = Intersect(Range("F6"), Target)
On Error Resume Next
If Not xRg Is Nothing Then
Target.Worksheet.Unprotect Password:="1234"
xRg.MergeArea.Locked = True
Target.Worksheet.Protect Password:="1234"
End If
End Sub

How to merge two subs with Private Sub Worksheet_Change on sheet

good morning
I need to combine two Private Sub Worksheet_Change(ByVal Target As Range) I'm new to Excel VBA code, how can I do this? Code below.
1)
Option Explicit
Const strAFM As String = "D3:D1000"
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, AFM As String, rngTomi As Range
Set Rng = Range(strAFM)
Set rngTomi = Intersect(Target, Rng)
If rngTomi Is Nothing Then Exit Sub
If rngTomi.Count <> 1 Then
rngTomi.ClearContents
Exit Sub
End If
If Trim(Target.Value) = "" Then Exit Sub
AFM = Right("000000000" & Target.Value, 9)
If isAFM(AFM) = False Then
MsgBox "no afm"
Target.Activate
Exit Sub
End If
End Sub
2)
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
Dim Rng As Range
Set Rng = Me.Range("ColTarget")
If Intersect(Target, Rng) Is Nothing Then Exit Sub
ResizeTbl
End Sub
Try:
Option Explicit
Const strAFM As String = "D3:D1000"
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, AFM As String, rngTomi As Range
If Not Target.Count > 1 Then
Set Rng = Me.Range("ColTarget")
If Not Intersect(Target, Rng) Is Nothing Then ResizeTbl
End If
Set Rng = Range(strAFM)
Set rngTomi = Intersect(Target, Rng)
If Not rngTomi Is Nothing Then
If rngTomi.Count <> 1 Then
Application.EnableEvents = False
rngTomi.ClearContents
Application.EnableEvents = False
Exit Sub
End If
If Trim(Target.Value) = "" Then Exit Sub
AFM = Right("000000000" & Target.Value, 9)
If isAFM(AFM) = False Then
MsgBox "no afm"
Target.Activate
Exit Sub
End If
End If
End Sub

Combine two "Private Sub Worksheet_Change(ByVal Target As Range)"

I have the following two codes in my sheet, and I want them both to run - currently I get a macro error. Could you help me to combine them so that they both run??
One enters the date in an adjacent cell when data is entered, the other allows multiple selections from a dropdown list. Both work individually.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim WorkRng As Range
Dim Rng As Range
Dim xOffsetColumn As Integer
Set WorkRng = Intersect(Application.ActiveSheet.Range("O:O"), Target)
xOffsetColumn = 1
If Not WorkRng Is Nothing Then
Application.EnableEvents = False
For Each Rng In WorkRng
If Not VBA.IsEmpty(Rng.Value) Then
Rng.Offset(0, xOffsetColumn).Value = Now
Rng.Offset(0, xOffsetColumn).NumberFormat = "dd/mm/yyyy"
Else
Rng.Offset(0, xOffsetColumn).ClearContents
End If
Next
Application.EnableEvents = True
End If
End Sub
And the other code is:
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 Target.Column = 10 _
Or Target.Column = 12 Then
If oldVal = "" Then
'do nothing
Else
If newVal = "" Then
'do nothing
Else
Target.Value = oldVal _
& ", " & newVal
' NOTE: you can use a line break,
' instead of a comma
' Target.Value = oldVal _
' & Chr(10) & newVal
End If
End If
End If
End If
exitHandler:
Application.EnableEvents = True
End Sub
Many thanks
You can only have one Worksheet_Change event per sheet. A simple work around is to turn your two Events into Sub Procedures and then create a master Event that simply calls both of your other subs.
The set up will look something like this
Event
Private Sub Worksheet_Change(ByVal Target As Range)
AddDate Target
Dropdown Target
End Sub
Sub Procedure 1
Sub AddDate (Target as Range)
'Your first code goes here
End Sub
Sub Procedure 2
Sub Dropdown (Target as Range)
'Your second code goes here
End Sub
I would personally set up your validations in the Event and call your procedures accordingly. Then your subs can strictly focus on the action statements rather needing to do any validation.
That may look something like this (notice all of your range variables are already initiated and no longer need to be declared)
Private Sub Worksheet_Change(ByVal Target As Range)
'DateAdd Validation
Dim WorkRng As Range
Set WorkRng = Intersect(Application.ActiveSheet.Range("O:O"), Target)
If Not WorkRng Is Nothing Then
DateAdd Target, WorkRng
End If
'Dropdown Validation
Dim rngDV As Range
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
If Target.Count = 1 Then
If Not rngDV Is Nothing Then '<-- I believe this is redundant
If Not Intersect(Target, rngDV) Is Nothing Then
Dropdown Target, rngDV
End If
End If
End If
End Sub
Sub DateAdd(Target As Range, WorkRng As Range)
End Sub
Sub Dropdown(Target As Range, rngDV As Range)
End Sub

Save previous cell VALUES and not only the last one (modify my code)

I found this interesting code that is almost perfect for my needs.
When a cell changes value, this code save the old value in another cell.
The problem is that when I change it again, it overwrite the previous "old value". So, at the end, I only have my "N value" and my "N-1 value".
What should I do to keep all the previous values?
Let's say that I'm modifying the cell A1, the old value goes to B1.
I thought about a CONCATENATE function, save the B1 somewhere else, but I feel I'm going in a wrong way.
Thank you so much for your patience and time.
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, 7)
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("C:C"))
End If
Label1:
Set xRg = Intersect(Target, Range("C:C"))
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).Formula
Next
Next
Set xChangeRg = Nothing
Set xRg = Nothing
Set xDependRg = Nothing
Application.EnableEvents = True
End Sub

Resources