Two Private Subs in One Worksheet [duplicate] - excel

I am looking to limit my workbook users to 1000 characters over a range of cells (Example: A5:A30).
In other words limit the total characters in the range A5:A30 to 1000 characters.
When a user fills in a cell that sends the range over the 1000 character limit, it will call Application.undo which should just remove the last text that they added.
However since I have another Private Sub Worksheet_Change(ByVal Targe As Range) on the worksheet, it causes a bug.
Below is both Worksheet_Change subs. Both use the same cells.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim charCount As Long
If Not Intersect(Target, Range("E6,E11,E16")) Is Nothing Then
Dim arrValues As Variant
arrValues = Range("E6,E11,E16").Value2
Dim i As Long
Dim tempSplit As Variant
Dim j As Long
For i = LBound(arrValues) To UBound(arrValues)
tempSplit = Split(arrValues(i, 1), " ")
For j = LBound(tempSplit) To UBound(tempSplit)
charCount = charCount + Len(tempSplit(j))
Next j
Next i
End If
If charCount > 1000 Then
Application.Undo
MsgBox "Adding this exceeds the 1000 character limit"
End If
If Not Intersect(Target, Range("D6")) Is Nothing Then
If Target.Value2 = "Material" Then
'assumes the comment cell is one column to the right
Target.Offset(0, 1) = "**"
End If
End If
If Not Intersect(Target, Range("D7")) Is Nothing Then
If Target.Value2 = "Material" Then
'assumes the comment cell is one column to the right
Target.Offset(-1, 1) = "**"
End If
End If
If Not Intersect(Target, Range("D8")) Is Nothing Then
If Target.Value2 = "Material" Then
Target.Offset(-2, 1) = "**"
End If
End If
End Sub
Is there a way around this so I can have two Worksheet_Change on the same worksheet?

You cannot have two Worksheeet_Change events in one sheet. But, one is quite enough:
Private Sub Worksheet_Change(ByVal Target As Range)
Select Case True
Case Not Intersect(ActiveCell, Range("A5:A30")) Is Nothing
DoThingOne
Case Not Intersect(ActiveCell, Range("B5:B30")) Is Nothing
DoThingTwo
End Select
End Sub
Private Sub DoThingOne()
Debug.Print "THING ONE"
End Sub
Private Sub DoThingTwo()
Debug.Print "THING TWO"
End Sub

How about this revision using Vityata's idea?
Private Sub Worksheet_Change(ByVal Target As Range)
Select Case True
Case Not Intersect(Target, Range("E6,E11,E16")) Is Nothing
Dim charCount As Long
Dim arrValues As Variant
arrValues = Range("E6,E11,E16").Value2
Dim i As Long
Dim tempSplit As Variant
Dim j As Long
For i = LBound(arrValues) To UBound(arrValues)
tempSplit = Split(arrValues(i, 1), " ")
For j = LBound(tempSplit) To UBound(tempSplit)
charCount = charCount + Len(tempSplit(j))
Next j
Next i
If charCount > 1000 Then
With Application
.EnableEvents = False
.Undo
.EnableEvents = True
End With
MsgBox "Adding this exceeds the 1000 character limit"
End If
Case Not Intersect(Target, Range("D6")) Is Nothing
If Target.Value2 = "Material" Then
'assumes the comment cell is one column to the right
Target.Offset(0, 1) = "**"
End If
Case Not Intersect(Target, Range("D7")) Is Nothing
If Target.Value2 = "Material" Then
'assumes the comment cell is one column to the right
Target.Offset(-1, 1) = "**"
End If
Case Not Intersect(Target, Range("D8")) Is Nothing
If Target.Value2 = "Material" Then
Target.Offset(-2, 1) = "**"
End If
End Select
End Sub

Related

Log changes in Excel spreadsheet using VBA

I have the following problem. I need to log changes in a spreadsheet. My range goes from A1:M300000.
So far I have managed to log the address of the changed cell, the user, the old value, and the new value.
Now I would like to insert the following functions and need help. It's the first time I come into contact with VBA:
I also want my log file to show the value of a cell in another column. So I know which object it is. Example change cell B26 and now also A26 should be displayed in the log file.
Furthermore, I also want to log when new cells are inserted or existing records are deleted.
Here is my VBA code:
Option Explicit
Dim mvntWert As Variant
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wks As Worksheet
Dim lngLast As Long
Set wks = Worksheets("Protokoll")
lngLast = wks.Range("A65536").End(xlUp).Row + 1
If Target.Count > 1 Then Exit Sub
If Intersect(Range("A1:M65536"), Target) Is Nothing Then Exit Sub
With wks
.Range("A" & lngLast).Value = Target.Address(0, 0)
.Range("B" & lngLast).Value = mvntWert
.Range("C" & lngLast).Value = Target.Value
.Range("D" & lngLast).Value = VBA.Environ("Username")
.Range("E" & lngLast).Value = Now
End With
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Intersect(Range("A1:M65536"), Target) Is Nothing Then Exit Sub
mvntWert = Target.Value
End Sub
I hope someone can help me. Thank you very much in advance.
greeting
ironman
Please, try the next code, I prepared yesterday for somebody else asking for a similar issue. It needs only one event and should do what you require here:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim RangeValues As Variant, r As Long, boolOne As Boolean, TgValue 'the array to keep Target values (before UnDo)
Dim sh As Worksheet: Set sh = Worksheets("Protokoll")
Dim UN As String: UN = Application.userName
'sh.Unprotect "" 'it should be good to protect the sheet
If sh.Range("A1") = "" Then sh.Range("A1").Resize(1, 6) = _
Array("Time", "User Name", "Changed cell", "From", "To", "Sheet Name")
Application.ScreenUpdating = False 'to optimize the code (make it faster)
Application.Calculation = xlCalculationManual
If Target.cells.count > 1 Then
TgValue = extractData(Target)
Else
TgValue = Array(Array(Target.value, Target.Address(0, 0))) 'put the target range in an array (or as a string for a single cell)
boolOne = True
End If
Application.EnableEvents = False 'avoiding to trigger the change event after UnDo
Application.Undo
RangeValues = extractData(Target) 'define the RangeValue
putDataBack TgValue, ActiveSheet 'put back the changed data
If boolOne Then Target.Offset(1).Select
Application.EnableEvents = True
Dim columnHeader As String, rowHeader As String
For r = 0 To UBound(RangeValues)
If RangeValues(r)(0) <> TgValue(r)(0) Then
sh.cells(rows.count, 1).End(xlUp).Offset(1, 0).Resize(1, 6).value = _
Array(Now, UN, RangeValues(r)(1), RangeValues(r)(0), TgValue(r)(0), Target.Parent.Name)
End If
Next r
'sh.Protect ""
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub putDataBack(arr, sh As Worksheet)
Dim i As Long, arrInt, El
For Each El In arr
sh.Range(El(1)).value = El(0)
Next
End Sub
Function extractData(rng As Range) As Variant
Dim a As Range, arr, count As Long, i As Long
ReDim arr(rng.cells.count - 1)
For Each a In rng.Areas 'creating a jagged array containing the values and the cells address
For i = 1 To a.cells.count
arr(count) = Array(a.cells(i).value, a.cells(i).Address(0, 0)): count = count + 1
Next
Next
extractData = arr
End Function

Update excel cell with date if a cell in a range is update

I need to update a cell with the date and time stamp (NOW()) if any cell is updated within any cell before it within that same row.
So update cell "CU" with date and time when any cell from "A-CR" is updated.
I have done some searching but I can only seem to find bits that work if only updating a single cell, I'm looking for if anything changes within that range.
I currently have some Vba which does something similar which will update the adjacent cell with time and date which is required but I also need an overall one for the whole process.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("F:F, I:I, L:L, O:O, R:R, U:U, X:X, AA:AA, AB:AB, AE:AE, AH:AH, AK:AK, AN:AN, AQ:AQ, AT:AT, AW:AW, AZ:AZ, BC:BC, BF:BF, BI:BI, BL:BL, BO:BO, BR:BR, BU:BU, BX:BX, CA:CA, CD:CD, CG:CG, CJ:CJ, CM:CM, CP:CP")) Is Nothing Then
On Error GoTo safe_exit
With Application
.EnableEvents = False
.ScreenUpdating = False
Dim trgt As Range, ws1 As Worksheet
'Set ws1 = ThisWorkbook.Worksheets("Info")
For Each trgt In Intersect(Target, Range("F:F, I:I, L:L, O:O, R:R, U:U, X:X, AA:AA, AB:AB, AE:AE, AH:AH, AK:AK, AN:AN, AQ:AQ, AT:AT, AW:AW, AZ:AZ, BC:BC, BF:BF, BI:BI, BL:BL, BO:BO, BR:BR, BU:BU, BX:BX, CA:CA, CD:CD, CG:CG, CJ:CJ, CM:CM, CP:CP"))
If trgt <> vbNullString Then
If UCase(trgt.Value) = "Y" Or UCase(trgt.Value) = "N" Then
Cells(trgt.Row, trgt.Column + 1) = Now()
Cells(trgt.Row, trgt.Column + 2) = Environ("username")
'Select Case trgt.Column
' Case 2 'column B
' Cells(trgt.Row, trgt.Column + 1) = Environ("username")
' Case 4 'column D
' 'do something else
' End Select
Else
trgt = ""
Cells(trgt.Row, trgt.Column + 1) = ""
Cells(trgt.Row, trgt.Column + 2) = ""
End If
End If
Next trgt
'Set ws1 = Nothing
End With
End If
safe_exit:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
This works for me:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Intersect(Target, Me.Range("A" & Target.Row & ":CR" & Target.Row)) Is Nothing Then GoTo SafeExit
Me.Cells(Target.Row, "CU") = Now()
SafeExit:
Application.EnableEvents = True
End Sub
The below code takes care of:
Clearing the time if the row is blank.
Updating the time only if the values really change from the previous value.
Dim oldValue As String
'Change the range below where your data will be
Const RangeString = "A:CR"
'Below variable decides the column in which date will be displayed
'Change the below value to 1 for column A, 2 for B, ... 99 for CU
Const ColumnIndex = 99
Private Sub Worksheet_Change(ByVal Target As Range)
Dim WorkRng As Range
Dim HorizontalRng As Range
Dim Rng As Range
Dim HorRng As Range
Dim RowHasVal As Boolean
Set WorkRng = Intersect(ActiveSheet.Range(RangeString), Target)
If Not WorkRng Is Nothing Then
If WorkRng.Cells.Count = 1 And WorkRng.Cells(1, 1).Value = oldValue Then
Exit Sub
End If
Application.EnableEvents = False
For Each Rng In WorkRng
Set HorizontalRng = Intersect(ActiveSheet.Range(RangeString), Rows(Rng.Row))
RowHasVal = False
For Each HorRng In HorizontalRng
If Not VBA.IsEmpty(HorRng.Value) Then
RowHasVal = True
Exit For
End If
Next
If Not RowHasVal Then
ActiveSheet.Cells(Rng.Row, ColumnIndex).ClearContents
ElseIf Not VBA.IsEmpty(Rng.Value) Then
ActiveSheet.Cells(Rng.Row, ColumnIndex).Value = Now
ActiveSheet.Cells(Rng.Row, ColumnIndex).NumberFormat = "dd-mm-yyyy, hh:mm:ss"
End If
Next
Application.EnableEvents = True
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, ActiveSheet.Range(RangeString)) Is Nothing Then
If Target.Cells.Count = 1 Then
oldValue = Target.Value
Else
oldValue = ""
End If
End If
End Sub

How can we find the last item entered within a column

How can we find the last item entered within a column?(note that the last entered item may be A4, while we have data till A1000)
Thanks
If you need the value of the last item entered, then include this event macro in the worksheet code area:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim CellsToWatch As Range, LastValue As Range
Set CellsToWatch = Range("A1:A1000")
Set LastValue = Range("B1")
If Target.Count > 1 Then Exit Sub
If Intersect(Target, CellsToWatch) Is Nothing Then Exit Sub
Application.EnableEvents = False
LastValue.Value = Target.Value
Application.EnableEvents = True
End Sub
If you need the location of the last item entered, then use this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim CellsToWatch As Range, LastValue As Range
Set CellsToWatch = Range("A1:A1000")
Set LastValue = Range("B1")
If Target.Count > 1 Then Exit Sub
If Intersect(Target, CellsToWatch) Is Nothing Then Exit Sub
Application.EnableEvents = False
LastValue.Value = Target.Address
Application.EnableEvents = True
End Sub
The result will be stored in cell B1
I would create a helper column. This would be a date stamp that is generated using VBA. You can hide we'll just call it column B.
this will go under worksheet change event
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 Then
Application.EnableEvents = False
Me.Cells(Target.Row, 2) = Format(Date + Time, "mm/dd/yyyy h:nn:ss")
Application.EnableEvents = True
End If End Sub
Please note that in Me.Cells(Target.Row,2) the 2 is going to change according to which column you want your date in.
this will go in a separate Module:
Sub get_LastEntered()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim last_Time As Date
Dim last_Row As Long
Dim last_Row_Changed As Long
last_Row = ws.Cells(Rows.Count, 2).End(xlUp).Row
last_Time = Application.WorksheetFunction.Max(ws.Range("B1:B" & last_Row))
last_Row_Changed = Application.WorksheetFunction.Match(last_Time, ws.Range("B1:B" & last_Row),0)
MsgBox "The last Cell that you changed was:" & last_Row_Changed
End Sub

Create comments to a range of cells ftom the values of another range of cells

I want to create comments to a range of cells. The comments should contain the values of another range of cells.
Here is what I have so far:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sResult As String
If Union(Target, Range("A18")).Address = Target.Address Then
Application.EnableEvents = False
Application.ScreenUpdating = False
sResult = "Maximal " & Target.Value
With Range("I6")
.ClearComments
.AddComment
.Comment.Text Text:=sResult
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End Sub
This works for one cell. I need this for a range of cells. For example, let's say I need the values of cells A1:F20 in comments of cells A21:F40. I do not want to copy the same Sub as many times.
It should do you the job if you replace
With Range("I6")
.ClearComments
.AddComment
.Comment.Text Text:=sResult
End With
with
For Each cell In Range("A1", "F20").Cells
Dim V As Range
Set V = cell.Offset(20, 0)
With cell
.ClearComments
If Not IsEmpty(V) Then
.AddComment V.Value
End If
End With
Next
This will basically ignore all empty cells.
Output:
My code:
Sub TEST()
For Each cell In Range("A1", "F20").Cells
Dim V As Range
Set V = cell.Offset(20, 0)
With cell
.ClearComments
If Not IsEmpty(V) Then
.AddComment V.Value
End If
End With
Next
End Sub
I made some adaptions to your advices, thanks a lot, this solved my problem:
Private Sub Worksheet_Change(ByVal target As Range)
Dim src As Range: Set src = Worksheets("maxleft").Range("C2:K11")
Dim tar As Range: Set tar = Range("I6:Q15")
For i = 0 To tar.Rows.Count - 1
For j = 0 To tar.Columns.Count - 1
Dim sResult As String
sResult = "Maximal " & Worksheets("maxleft").Cells(src.Row + i, src.Column + j)
With Cells(tar.Row + i, tar.Column + j)
.ClearComments
.AddComment
.Comment.Text Text:=sResult
End With
Next j
Next i
End Sub
From your question I understand that you want to select a range of cells (e.g. "A1:A5"), then select another range of cells (e.g. "B6:B10") and the respective values of the first selected Range should be placed as comments in the secon selected Range. Is this correct?
The following code checks if 2 ranges with an equal length are selected and copies the values of the first selected range as comments to the second selected range:
Private Sub Worksheet_SelectionChange(ByVal target As Range)
If InStr(target.Address, ",") Then
Dim selected_range() As String
selected_range = Split(target.Address, ",")
If Range(selected_range(0)).Rows.Count = Range(selected_range(1)).Rows.Count Then
Dim src As Range: Set src = Range(selected_range(0))
Dim tar As Range: Set tar = Range(selected_range(1))
For i = 0 To src.Rows.Count - 1
Dim sResult As String
sResult = "Maximal " & Cells(src.Row + i, src.Column)
With Cells(tar.Row + i, tar.Column)
.ClearComments
.AddComment
.Comment.Text Text:=sResult
End With
Next i
End If
End If
End Sub

Clear the contents of columns B to F if cell A is empty

I have a worksheet with values depending on Cell A. If a row in column A contains a value then cells from Columns B through H will be changed accordingly.
If Cell of Column A is empty I want to reset the cells from columns D through F.
I wrote down the following VBA Code
Private Sub Worksheet_Change(ByVal Target As Range)
Dim n As Integer
For n = 5 To 75
Application.EnableEvents = False
If VarType(Cells(n, 1)) = vbEmpty Then
Cells(n, 4).ClearContents
Cells(n, 5).ClearContents
Cells(n, 6).ClearContents
Application.EnableEvents = True
End If
Next n
End Sub
The "FOR" Loop is annoying, and making the Excel to pause for 1 second or more after any entry to any Cell, can anyone help me correct the above code to do what I need to do without the "FOR" loop.
You are using a Worksheet_Change event and you iterating through 70 rows each time something changes.. this is a bad approach for this kind of problem and that's why there is a delay.
Instead, try
Private Sub Worksheet_Change(ByVal Target As Range)
Dim n As Long
If Target.Column = 1 Then
If IsEmpty(Cells(Target.Row, 1)) Then
Range("B" & Target.Row & ":F" & Target.Row).ClearContents
End If
End If
End Sub
this will only clear the cells if you remove a value from column A => when cell in column A is empty
Try this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
If Mid(Target.Address(1, 1), 1, 2) = "$A" Then
If Target.Cells(1, 1).Value = "" Then
For i = 4 To 6
Target.Cells(1, i).Value = ""
Next i
End If
End If
End Sub
Give this a try:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rLook As Range, r As Range, Intr As Range
Set rLook = Range("A5:A75")
Set Intr = Intersect(rLook, Target)
If Intr Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Intr
If r.Value = "" Then
rw = r.Row
Range("D" & rw & ":F" & rw).ClearContents
End If
Next r
Application.EnableEvents = True
End Sub
It should have minimal impact on timing.
Use a range object.
The following line of code will print the address of the Range we'll use to clear the contents. The first cells call gets the upper left corner of the range, the second cells call gets the lower right corner of the range.
Private Sub test()
Debug.Print Range(Cells(5, 4), Cells(75, 6)).Address
End Sub
We apply this to your code like this:
Private Sub Worksheet_Change(ByVal Target As Range)
If VarType(Cells(Target.Row, 1)) = vbEmpty Then
Application.EnableEvents = False
Range(Cells(Target.Row, 4), Cells(Target.Row, 6)).ClearContents
Application.EnableEvents = True
End If
End Sub
One final sidenote: You should use an error handler to make sure events are always enabled when the sub exits, even if an error occurs.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ErrHandler
If VarType(Cells(Target.Row, 1)) = vbEmpty Then
Application.EnableEvents = False
Range(Cells(Target.Row, 4), Cells(Target.Row, 6)).ClearContents
End If
ExitSub:
Application.EnableEvents = True
Exit Sub
ErrHandler:
MsgBox "Oh Noes!", vbCritical
Resume ExitSub
End Sub
You should disable events and cater for multiple cells when using the Change event.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng1 As Range
Dim rng2 As Range
Set rng1 = Intersect(Columns("A"), Target)
If rng1 Is Nothing Then Exit Sub
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
For Each rng2 In rng1.Cells
If IsEmpty(rng2.Value) Then rng2.Offset(0, 1).Resize(1, 5).ClearContents
Next
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
For those that need to have data entered in one cell cleared (in a column) when there's a change in another column use this, which is a modification of Gary's Student.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rLook As Range, r As Range, Intr As Range
Set rLook = Range("D:D")
Set Intr = Intersect(rLook, Target)
If Intr Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Intr
If r.Value = "" Then
rw = r.Row
Range("L:L").ClearContents
End If
Next r
Application.EnableEvents = True
End Sub

Resources