2013 Excel VBA remove contents of a cell when deleting another - vba

Below is the vba code I am using to auto-populate the date in column 3 when a number is entered in column 1. I need the date to be removed when the number in Column 1 is deleted.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range, B As Range, Inte As Range, r As Range
Set A = Range("A:A")
Set Inte = Intersect(A, Target)
If Inte Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Inte
r.Offset(0, 2).Value = Date
Next r
Application.EnableEvents = True
End Sub

It was having a problem because the deletion of column 3 triggers another changestate, so I just put something at the top saying if the change isn't in column 1 then don't worry bout it. This should work:
Private Sub Worksheet_Change(ByVal Target As Range)
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 Inte Is Nothing Then Target.Offset(0, 3 - Target.Column).Value = "YES"
If Target.Offset(0, 1 - Target.Column).Value = "" Then
Target.Offset(0, 3 - Target.Column).Clear
Exit Sub
End If
'If Inte Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Inte
r.Offset(0, 2).Value = Date
Next r
Application.EnableEvents = True
End If
End Sub

Related

how to get VLOOKUP value from another workbook?

Below code is working good with same workbook. But when I am trying to get VLOOKUP value from another workbook, it is not getting the value.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngCell As Range, m1 As Variant ', m2 As Variant
On Error GoTo Hello:
If Application.Intersect(Target, Range("C2:C100001")) Is Nothing Then Exit Sub
For Each rngCell In Intersect(Target, Range("C2:C100001"))
If Len(rngCell.Value) > 0 Then
'This line is working good
'm1 = Application.VLookup(rngCell.Value, ThisWorkbook.Sheets("AllVehicleNumbers").Range("B2:C100001"), 2, False)
'But this is not working
m1 = Application.VLookup(rngCell.Value, Workbooks(ThisWorkbook.Path & "\VehicleNumbers.xlsx").Worksheets("AllVehicleNumbers").Range("B2:C100001"), 2, False)
If Not IsError(m1) Then
Application.EnableEvents = False
rngCell.Value = m1
Application.EnableEvents = True
End If
End If
Next
Hello:
End Sub
This will work on a closed workbook:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range, rng As Range, v, frm
On Error GoTo haveError
Set rng = Application.Intersect(Target, Me.Range("C2:C100001"))
If rng Is Nothing Then Exit Sub
'Note your formula will vary a little if you're looking up numeric values
' (no quotes around the lookup value)
frm = "=VLOOKUP(""<v>"",'" & ThisWorkbook.Path & _
"\[VehicleNumbers.xlsx]AllVehicleNumbers'!B2:C100001,2,FALSE)"
For Each c In rng.Cells
v = Trim(c.Value)
If Len(v) > 0 Then
Application.EnableEvents = False
c.Formula = Replace(frm, "<v>", v)
c.Calculate
If IsError(c.Value) Then
c.Value = v 'no match - replace the original value
c.Font.Color = vbRed 'flag no match
Else
c.Value = c.Value 'convert to value
c.Font.Color = vbBlack 'clear any flag
End If
Application.EnableEvents = True
End If
Next
Exit Sub
haveError:
Application.EnableEvents = True
End Sub

Running multiple event macros

I discovered this Event macro and it is exactly what I need. However I have multiple points of data entry that need to generate a static date and timestamp. I have not been successful in running multiple instances of this macro.
Example: I enter data in A, date and time generate in C,D. Then I enter data in J, date and time generate in M,N. etc.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range, B As Range, Inte As Range, r As Range
Set A = Range("D:D")
Set Inte = Intersect(A, Target)
If Inte Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Inte
If r.Value > 0 Then
r.Offset(0, -3).Value = Date
r.Offset(0, -3).NumberFormat = "dd-mm-yyyy"
r.Offset(0, -2).Value = Time
r.Offset(0, -2).NumberFormat = "hh:mm:ss AM/PM"
Else
r.Offset(0, -3).Value = ""
r.Offset(0, -2).Value = ""
End If
Next r
Application.EnableEvents = True
End Sub
To include column J, Change:
Set A = Range("D:D")
to:
Set A = Range("D:D,J:J")

Run-time error '1004': Method 'Intersect' of object' _Global' failed

I'm still fairly new at this and was trying to find an answer. Maybe it's not defined correctly or at all. Maybe it's not pointing to correct work sheet. I'm not really sure... Any help would be greatly appreciated! Thanks!
Getting error on this line:
Set Inte = Intersect(A, Target)
Error code is:
Run-time error '1004': Method 'Intersect' of object'_Global' failed
Full code:
Private Sub Worksheet_Change(ByVal Target As Range)
'Determine Target Colunm
If Target.Column = 10 Then
'Check for "TD", Copy/Delete Row if found
If Target = "TD" Then
Application.EnableEvents = False
nxtRow = Sheets("TD Locks").Range("J" & Rows.Count).End(xlUp).Row + 1
Target.EntireRow.Copy _
Destination:=Sheets("TD Locks").Range("A" & nxtRow)
Target.EntireRow.Delete
Application.EnableEvents = True
Exit Sub
End If
'Check for "Closed", Copy/Delete Row if found
If Target = "Closed" Then
Application.EnableEvents = False
nxtRow = Sheets("Closed Locks").Range("J" & Rows.Count).End(xlUp).Row + 1
Target.EntireRow.Copy _
Destination:=Sheets("Closed Locks").Range("A" & nxtRow)
Target.EntireRow.Delete
Application.EnableEvents = True
End If
End If
'Adds date when borrower name is entered
Dim A As Range, B As Range, Inte As Range, r As Range
Set A = Range("C:C")
Set Inte = Intersect(A, Target)
If Inte Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Inte
If r.Offset(0, 8).Value = "" Then
r.Offset(0, 8).Value = Date
End If
Next r
Application.EnableEvents = True
End Sub
there's a "devil touch" in your code since if the user types "Closed" in column "J" of the sheet in whose module you're placing this event handler, it deletes the target row (Target.EntireRow.Delete), thus leaving target unreferenced and preparing the ground for throwing an error in any subsequent use of target, which happens to be in Set Inte = Intersect(A, Target)
But If I correctly read your code, this shouldn't even happen since this latter line gets done only should target cross column "C", which can't be if it's in column "J"!.
If what above is correct you may want to use a code like the following
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim nxtRow As Long
Dim Inte As Range, r As Range
Application.EnableEvents = False
With Target
'Determine Target Colunm
If .Column = 10 Then
'Check for "Closed", Copy/Delete Row if found
If .Value = "Closed" Then
nxtRow = Sheets("Closed Locks").Range("J" & Rows.Count).End(xlUp).Row + 1
.EntireRow.Copy _
Destination:=Sheets("Closed Locks").Range("A" & nxtRow)
.EntireRow.Delete
ElseIf Target = "TD" Then
'Check for "TD", Copy/Delete Row if found
nxtRow = Sheets("TD Locks").Range("J" & Rows.Count).End(xlUp).Row + 1
.EntireRow.Copy _
Destination:=Sheets("TD Locks").Range("A" & nxtRow)
.EntireRow.Delete
End If
Else
'Adds date when borrower name is entered
Set Inte = Intersect(.Cells, .Parent.Range("C:C"))
If Not Inte Is Nothing Then
For Each r In Inte
If r.Offset(0, 8).Value = "" Then r.Offset(0, 8).Value = Date
Next r
End If
End If
End With
Application.EnableEvents = True
End Sub
Does it work if you change the problem line with this:
if not intersect(A, Target) is nothing then Set Inte = Intersect(A, Target)

Need this to work with a button press

I found this code on this site that works for what I'm trying to do with a sign out log with one exception - it works as a worksheet update function right now and I need it to only work when a button is pressed. How would I modify this code so that it can be a macro that would be assigned to a button? Any help would be greatly appreciated.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range, B As Range, Inte As Range, r As Range
Set A = Range("A:A")
Set Inte = Intersect(A, Target)
If Inte Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In Inte
If r.Offset(0, 1).Value = "" Then
r.Offset(0, 1).Value = Date
End If
Next r
Application.EnableEvents = True End Sub
If you want to keep checking for values in column A only, then
Sub clickMe()
Dim A As Range, Inte As Range, r As Range
Set A = Range("A:A")
Set Inte = Intersect(A, Selection)
If Inte Is Nothing Then Exit Sub
For Each r In Inte
If r.Offset(0, 1).Value = "" Then
r.Offset(0, 1).Value = Date
End If
Next r
End Sub
If the column does not matter and the button should enter a date to the right of the selected cell, then
Sub clickMe()
Dim r As Range
For Each r In Selection
If r.Offset(0, 1).Value = "" Then
r.Offset(0, 1).Value = Date
End If
Next r
End Sub

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.