#VBA Private Sub Worksheet_Change - vba

Could any kind soul help me, I have spent a considerable amount of time searching and trying to get these 2 pieces of code to work, but couldn't.
Is there any way I can combine these 2 snippets? They serve two different purposes.
1.
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
If Len(Target) = 10 Then
Range("I" & Target.Row & ":J" & Target.Row & ", K" & Target.Row & ", M" & Target.Row) = "N"
End If
End Sub
2.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 12 And Target.Value = "Y" Then
Target.Offset(0, 1) = Date
End If
End Sub
I am at a loss....

You could use the code below.
Disable events to stop the Change event firing when you update the values in columns I:K & N.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ERR_HANDLE
Application.EnableEvents = False
With Target
If .Column = 12 Then
If .Value = "Y" Then
.Offset(, 1) = Date
End If
ElseIf .Column = 1 Then
If Len(.Value) = 10 Then
Cells(.Row, 9).Resize(, 3) = "N" 'Column I:K
Cells(.Row, 13) = "N" 'Column M
End If
End If
End With
EXIT_PROC:
Application.EnableEvents = True
On Error GoTo 0
Exit Sub
ERR_HANDLE:
Select Case Err.Number
Case 13 'Type mismatch.
Resume EXIT_PROC
Case Else 'Any unhandled errors.
MsgBox "Error " & Err.Number & vbCr & _
Err.Description, vbOKOnly, "Error in " & ThisWorkbook.Name
Resume EXIT_PROC
End Select
End Sub
Edit after accepted:
I've added an error handler to the code at the suggestion of #MathieuGuindon. After dealing with the error the code jumps back to the EXIT_PROC label so there's only a single exit point to the procedure.

You can try this as a combined method:
You need do disable alerts when making changes while you have a worksheet_change event loaded on a macro, else you may find yourself in a infinite loop.
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A:A")) Is Nothing Or Target.Column <> 12 Then Exit Sub
If Len(Target) = 10 Then
Application.EnableEvents = False
Range(Cells(Target.Row, "I"), Cells(Target.Row, "K")) = "N"
Range("M" & Target.Row) = "N"
Application.EnableEvents = True
End If
If Target.Column = 12 And Target.Value = "Y" Then
Application.EnableEvents = False
Target.Offset(0, 1) = Date
Application.EnableEvents = True
End If
End Sub

Related

Excel macro combine two Worksheet_Change code

I have two working Worksheet_Change code and I would like to use both of them on the same sheet. When I use them individually both of them work but when I use them together they do not. I tried to paste in two different codes but I got an ambiguous name detected error. I also tried to use elseif, next but none of them worked.
The two codes:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("O:O"), Target) Is Nothing Then
Cells(Target.Row, 17).Value = Date
End If
End Sub
and
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Target.Column = 15 Then
Range("P" & Target.Row).Value = Target.Value + Range("P" & Target.Row).Value
Application.EnableEvents = False
Target.Value = ""
Application.EnableEvents = True
End If
End Sub
Thank you for your help
you can just put both workshett Change events in the same sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("O:O"), Target) Is Nothing Then
Cells(Target.Row, 17).Value = Date
End If
If Target.Column = 15 Then
Range("P" & Target.Row).Value = Target.Value + Range("P" & Target.Row).Value
Application.EnableEvents = False
Target.Value = ""
Application.EnableEvents = True
End If
End Sub
Try it like this...
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.CountLarge > 1 Then Exit Sub
If Not Intersect(Range("O:O"), Target) Is Nothing Then
Application.EnableEvents = False
Cells(Target.Row, 17).Value = Date
Range("P" & Target.Row).Value = Target.Value + Range("P" & Target.Row).Value
Target.Value = ""
Application.EnableEvents = True
End If
End Sub

Display Warning Message when a protected cell has been clicked

Currently I have this code. In Column A, I have a current a "YES" or "No" Selection.
Private Sub worksheet_change(ByVal Target As Range)
If Not Intersect(Target, Range("A:A")) Is Nothing Then
ActiveSheet.Unprotect
If Target = "YES" Then
'Column B to S
For i = 1 To 18
With Target.Offset(0, i)
.Locked = False
.FormatConditions.Add Type:=xlExpression, Formula1:="=ISBLANK(" & Target.Offset(0, i).Address & ")"
With .FormatConditions(.FormatConditions.Count)
.SetFirstPriority
.Interior.ColorIndex = 4
End With
End With
Next i
ElseIf Target = "NO" Then
For i = 1 To 73
With Target.Offset(0, i)
.Value = ""
.Locked = True
.FormatConditions.Delete
End With
Next i
End If
ActiveSheet.Protect
End If
End Sub
Now when the user click the cell in Column T (19), I want to display a warning message to the user that this is not applicable for "Yes" selection.
This seems like it should do the task you are asking.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:A")) Is Nothing Then
On Error GoTo bm_SafeExit
Application.EnableEvents = False
Me.Unprotect
Dim trgt As Range
For Each trgt In Intersect(Target, Range("A:A"))
If LCase(trgt.Value2) = "yes" Then
With trgt.Offset(0, 1).Resize(1, 18)
.Locked = False
With .FormatConditions.Add(Type:=xlExpression, Formula1:="=ISBLANK(B" & trgt.Row & ")")
.Interior.ColorIndex = 4
End With
End With
Else
With trgt.Offset(0, 1).Resize(1, 73)
.Value = vbNullString
.Locked = True
.FormatConditions.Delete
End With
End If
Next trgt
End If
bm_SafeExit:
Application.EnableEvents = True
Me.Protect Userinterfaceonly:=True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("T:XFD")) Is Nothing Then
On Error GoTo bm_SafeExit
Application.EnableEvents = False
Dim trgt As Range
For Each trgt In Intersect(Target, Range("T:XFD"))
If LCase(Me.Cells(trgt.Row, "A").Value2) = "yes" Then
MsgBox "Don't try to put Yes here", vbCritical + vbOKOnly, "Bad Choice"
Me.Cells(trgt.Row, "A").Select
End If
Next trgt
End If
bm_SafeExit:
Application.EnableEvents = True
End Sub
Set watches and breakpoints and use [F8] and [Ctrl]+[F8} to walk through the code.

Tracking Share-drive Users name and opening time in Excel?

I have found a similar article about my question, as stated below;
How do I track who uses my Excel spreadsheet?
However, I do like the last coloumn of comment >>
"You could also put a time stamp in the next column to show when the spreadsheet was used"
My question is> can anyone guide me the possible step or let me copy the code for doing this please? and how to hide the worksheet without anyone noticing?
My key is, very importantly, everything must done silently which no one else (other users in sharedrive) could find out i m tracking it. The reason is , i have done lot of research worksheets, and i don't have time/impossible to make every single excel worksheet perfect, i need to prioritize them inorder to be efficient with my time by knowing which one is more important to people.
many thanks~!!
In Excel, under the Review tab, you have 'Track Changes'. This should do everything you want.
If you want a VBA script to do this, try one of the following code samples.
Private Sub Worksheet_Change(ByVal Target As Range)
Set t = Target
Set a = Range("A:A")
If Intersect(t, a) Is Nothing Then Exit Sub
Application.EnableEvents = False
t.Offset(0, 7).Value = Environ("username")
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim V As Long
Application.EnableEvents = False
Set rng1 = Application.Union(Range("a1:g1"), Range("H:iv"))
Set rng = Application.Intersect(Target, rng1)
If Not rng Is Nothing Then Exit Sub
V = Target.Offset(0, 12).Value
If Target.Offset(0, 12) = "" Then
With Range("H" & Target.Row)
.Value = Target.Address & ": first entry by " & Application.UserName & " at " & Now()
.ColumnWidth = 60
.Interior.ColorIndex = 33
End With
Target.Offset(0, 12).Value = Target.Value
Application.EnableEvents = True
Exit Sub
End If
Target.Offset(0, 12).Value = Target.Value
With Range("H" & Target.Row)
.Value = Target.Address & " changed from " & V & " to " & Target.Value & " by " & Application.UserName & " at " & Now()
.ColumnWidth = 60
.Interior.Color = vbYellow
End With
Application.EnableEvents = True
End Sub
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
With Target
If .Count > 1 Then Exit Sub
If Not Intersect(Range("A2:A10"), .Cells) Is Nothing Then
Application.EnableEvents = False
Sheets("Sheet2").Select
If IsEmpty(.Value) Then
.Offset(0, 1).ClearContents
Else
With .Offset(0, 1)
.NumberFormat = "dd mmm yyyy hh:mm:ss"
.Value = Now
End With
End If
Sheets("Sheet1").Select
Application.EnableEvents = True
End If
End With
End Sub
All of these 'Worksheet_Change' scripts are worksheet events. You need to right-click your sheet and click 'View Code' then paste the script into the window that opens. Try one at a time, not all three together.

Combining 2 "Private Sub Worksheet_Change(ByVal Target As Range)" into 1

I am creating an Excel spreadsheet. I have 2 separate functions that I need to combine but I am not sure how to smash them together. I know I can only have 1 change event. The first function will unprotect the sheet (column c is locked), auto populate column C when data is entered in to column A or erase C when A is erased and re-protect when complete. The second will return the cell focus to the next row, column A, when data is entered into A and B. Separately they work as needed.
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Unprotect Password:="my password"
If Target.Column = 1 Then
Dim A As Range, B As Range, Inte As Range, r As Range
Set A = Range("A:A")
Set Inte = Intersect(A, Target)
If Target.Offset(0, 1 - Target.Column).Value = "" Then
Target.Offset(0, 3 - Target.Column).Clear
Exit Sub
End If
Application.EnableEvents = False
For Each r In Inte
r.Offset(0, 2).Value = Date & " " & Time
r.Offset(0, 2).NumberFormat = "m/d/yyyy h:mm am/pm"
Next r
Application.EnableEvents = True
End If
Protect Password:="my password"
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Whoa
Application.EnableEvents = False
If Not Target.Cells.CountLarge > 1 Then
If Not Intersect(Target, Columns(1)) Is Nothing Then
Target.Offset(, 1).Select
ElseIf Not Intersect(Target, Columns(2)) Is Nothing Then
Target.Offset(1, -1).Select
End If
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
How about this, seems to do what you want, as I understand the question.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngIntersect As Range
Dim rngCell As Range
On Error GoTo TidyUp
Application.EnableEvents = False
If Target.Column = 1 Then
Set rngIntersect = Intersect(Range("A:A"), Target)
For Each rngCell In rngIntersect
If rngCell.Value = "" Then
rngCell.Offset(0, 2).Value = ""
Else
rngCell.Offset(0, 2).Value = Date & " " & Time
rngCell.Offset(0, 2).NumberFormat = "m/d/yyyy h:mm am/pm"
End If
Next rngCell
End If
If Target.Column < 3 And Target.Value <> "" Then ' lose the 'And Target.Value <> ""' as desired
Cells(Target.Row + Target.Rows.Count, 1).Select
End If
TidyUp:
Set rngIntersect = Nothing
Set rngCell = Nothing
Application.EnableEvents = True
End Sub
I'd also suggest using UserInterfaceOnly in your worksheet.Protect, then you don't have to unprotect the sheet for VBA to act on the sheet.
Implement it in two Sub-Procedures on a modul, then just call both of them in the Event-Procedure.

Entering a cellvalue if one of the cells in a range is changed and deleting it if range is empty

I want to make a code that adds a certain value to the first column if values are added to a certain range. And delete that value if that range is empty.
This is what I have so far, but I keep getting errors and I can't seem to figure out what I'm doing wrong.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, cell As Range
On Error GoTo haveError
Set rng = Application.Intersect(Target, Me.Range("B1:G100"))
If Not rng Is Nothing Then
Application.EnableEvents = False
For Each cell In rng.Cells
If cell.Value = "blah" Then
Range("A" & cell.Row).Value = "derp"
End If
Next
For Each cell In rng.Cells
If Range("B" & cell.Row, "G" & cell.Row).Value = "" Then
Range("A" & cell.Row).ClearContents
End If
Next
Application.EnableEvents = True
End If
Exit Sub
haveError:
MsgBox Err.Description
Application.EnableEvents = True
End Sub
You got Type mismatch error for wrong syntax in this line:
If Range("B" & cell.Row, "G" & cell.Row).Value = "" Then
So, I modified it and it work well. I also reduce one looping because both condition can set in only one looping.
Here, the full code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, cell As Range
On Error GoTo haveError
Set rng = Application.Intersect(Target, Me.Range("B1:G100"))
If Not rng Is Nothing Then
Application.EnableEvents = False
For Each cell In rng.Cells
If cell.Value = "blah" Then
Me.Range("A" & cell.Row).Value = "derp"
End If
If WorksheetFunction.CountA(Me.Range("B" & cell.Row & ":" & "G" & cell.Row)) = 0 Then
Me.Range("A" & cell.Row).ClearContents
End If
Next
Application.EnableEvents = True
End If
Exit Sub
haveError:
MsgBox Err.Description
Application.EnableEvents = True
End Sub
I've reorganized some commands and only performed actions when they are necessary.
Private Sub Worksheet_Change(ByVal Target As Range)
'don't do anything unless there is something to do
If Not Intersect(Target, Me.Range("B1:G100")) Is Nothing Then
On Error GoTo haveError
'don't declare vars until you kow you will need them
Dim rng As Range, cell As Range
Application.EnableEvents = False
Set rng = Application.Intersect(Target, Me.Range("B1:G100"))
For Each cell In rng.Cells
If cell.Value = "blah" Then
Range("A" & cell.Row).Value = "derp"
ElseIf Application.CountBlank(Cells(cell.Row, "B").Resize(1, 6)) = 6 Then
Cells(cell.Row, "A").ClearContents
End If
End If
GoTo safeExit
haveError:
If CBool(Err.Number) Then
'Debug.Print Err.Number & ": " & Err.Description
MsgBox Err.Number & ": " & Err.Description
Err.Clear
End If
safeExit:
Set rng = Nothing
Application.EnableEvents = True
End Sub
Rather than having two For Each...Next Statement, I've used an If ... ElseIf ... End If since the conditions are mutually exclusive (i.e. if one is true, the other cannot be true).