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)
Related
I have the setup as shown in the image above.
Logic of the macro is if I enter a number 1 in cell B5 or in empty cell in Range("B2:B26") then the output would be in this format:
B2 3
B3 4
B4 2
B5 1
Now it gives me that output but there are certain drawbacks e.g.
if I provide input 8 to the same cell then it will still increment the ranks. I incorporated a match check to see if that value is there or not but it doesn't seem to work Any help would be appreciated.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim KeyCells As Range
Dim i As Long, Cel As Range, sht1 As Worksheet, j As Long, found As Boolean
Set sht1 = Sheet1
Set KeyCells = sht1.Range("B2:C26")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
If Target.Column = 2 Then
For i = 2 To 26
If sht1.Range("B" & i) <> Empty And sht1.Range("B" & i).Value >= Target.Value And i <> Target.Row Then
sht1.Range("B" & i).Value = sht1.Range("B" & i).Value + 1
Else: End If
Next i
Else: End If
If Target.Column = 3 Then
For i = 2 To 26
If sht1.Range("C" & i) <> Empty And sht1.Range("C" & i).Value >= Target.Value And i <> Target.Row Then
sht1.Range("C" & i).Value = sht1.Range("C" & i).Value + 1
Else: End If
Next i
Else: End If
Else: End If
Call CreateDataLabels
Target.Select
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Is this what you are trying? I have not extensively tested it
Option Explicit
Dim rng As Range
Private Sub Worksheet_Change(ByVal Target As Range)
Dim oldVal As Long, i as Long
On Error GoTo Whoa
Application.EnableEvents = False
Set rng = Range("B2:B26")
If Not Intersect(Target, rng) Is Nothing Then
oldVal = Target.Value
If NumExists(oldVal, Target.Row) = True Then
For i = 2 To 26
If i <> Target.Row And Range("B" & i).Value >= oldVal Then _
Range("B" & i).Value = Range("B" & i) + 1
Next i
End If
End If
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
Function NumExists(n As Long, r As Long) As Boolean
Dim i As Long
For i = 2 To 26
If Range("B" & i) = n And r <> i Then
NumExists = True
Exit Function
End If
Next i
End Function
edited to remove "helper" values
edited to add functionality for column C as well
Being Siddharth Rout's answer the solution, and having the OP's not asked for anything more, I'd propose the following as an alternative option to possibly be discussed if worth considering
Option Explicit
Private Sub Worksheet_Change(ByVal target As Range)
Dim oldVal As Long
Dim wrkRng As Range
Application.EnableEvents = False
On Error GoTo EndThis
If Continue(target, Range("B2:C26").Cells, oldVal, wrkRng) Then '<== here you set "B2:C26" as the "sensitive" range
With wrkRng
.Offset(, 2).Value = .Value
.FormulaR1C1 = "=IF(RC[2]<>"""",RC[2]+IF(and(RC[2]>=" & oldVal & ",ROW(RC)<>" & target.Row & "),1,0),"""")"
.Value = .Value
.Offset(, 2).ClearContents
End With
End If
EndThis:
If Err Then MsgBox Err.Description
Application.EnableEvents = True
Exit Sub
End Sub
Function Continue(target As Range, rng As Range, oldVal As Long, wrkRng As Range) As Boolean
If target.Cells.Count = 1 Then
If Not IsEmpty(target) Then ' if cell has not been cancelled
Set wrkRng = Intersect(target.EntireColumn, rng)
If Not wrkRng Is Nothing Then
oldVal = target.Value
Continue = Application.WorksheetFunction.CountIf(wrkRng, oldVal) > 1
End If
End If
End If
End Function
as compared to Siddharth Rout's solution, it enhances the following:
more (complete?) testing as if to go on with rng processing
in previous solution
if you cancelled a cell in rng it'd add 1's in all rng cells
if you pasted values in more then one rng cells it'd throw an error
no use of cells iteration, both for oldVal counting purposes and for ranking updating
I'd like to know how to detect if the user is deleting or inserting content into a range. If they are deleting a range say D14:D18. I'd like to then perform a macro that also deletes content in E14:E18. I just wouldn't want to delete E14:E18 if they are entering content into D14:D18.
I've tried:
If Selection.ClearContents Then
MsgBox Target.Offset(0, 3).Style
End If
But this get's me stuck in an infinite loop.
A bit more context:
I have a few hundred cells in D:D for entering quantities for services. Not everything in D:D should be touched. Only cells in D:D with .Style = "UnitInput". In E:E I have data validation that lets the user only enter contractor 1 or contractor 2 But, when content is entered in D:D I run a macro to assign the default contractor (housed in F:F) to E:E. So when the user enters quantities into D:D it correctly assigns the default contractor. And when they delete singular items from D:D I have it handling proper removal of contractors. It's only when they delete a range of items from D:D.
Full code:
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
On Error GoTo ErrHandler:
If Selection.Rows.Count * Selection.Columns.Count = 1 Then
If Target.Offset(0, 3).Style = "Contractor" Then
If Target.Value < 1 Then
Target.Offset(0, 3).Value = ""
Else
Target.Offset(0, 3).Value = Target.Offset(0, 2).Value
End If
End If
If Target.Offset(0, 5).Style = "Markup" Then
If Target.Value = "" Then
Target.Offset(0, 5).Value = ""
ElseIf Target.Value <= Target.Offset(0, 14).Value Then
Target.Offset(0, 5).Value = "Redact 1"
ElseIf Target.Value >= Target.Offset(0, 15).Value Then
Target.Offset(0, 5).Value = "Redact 2"
Else
Target.Offset(0, 5).Value = "Redact 3"
End If
End If
Else
'!!!!!! this is where I need to handle multiple deletions. !!!!!!!
End If
Application.ScreenUpdating = True
ErrHandler:
Application.ScreenUpdating = True
Resume Next
End Sub
Based on your comments in chat, here is what I propose
UNTESTED
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, aCell As Range
Dim lRow As Long
'~~> Error handling, Switching off events and Intersect
'~~> As described in
'~~> http://stackoverflow.com/questions/13860894/ms-excel-crashes-when-vba-code-runs
On Error GoTo Whoa
Application.EnableEvents = False
With ActiveSheet
'~~> Find Last Row since data is dynamic
'~~> For further reading see
' http://stackoverflow.com/questions/11169445/error-in-finding-last-used-cell-in-vba
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
End If
If lRow > 12 Then
'~~> Set your range
Set rng = Range("D13:D" & lRow)
If Not Intersect(Target, rng) Is Nothing Then
For Each aCell In rng
If Len(Trim(aCell.Value)) = 0 Then
Select Case Target.Offset(0, 3).Style
Case "Contractor"
'~~> Do Your Stuff
Case "Markup"
'~~> Do Your Stuff
'
'~~> And so on
'
End Select
End If
Next aCell
End If
End If
End With
Letscontinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume Letscontinue
End Sub
Here is an idea -- you have to first select a region to clear its contents. Use selection change to record the number of non-blank cells and then worksheet change to see if it drops to zero. Something like:
Dim NumVals As Long
Private Sub Worksheet_Change(ByVal Target As Range)
Dim NewCount As Long
NewCount = Application.WorksheetFunction.CountA(Target)
If NewCount = 0 And NumVals > 0 Then MsgBox Target.Address & " was cleared"
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
NumVals = Application.WorksheetFunction.CountA(Target)
End Sub
I have this code is Sheet1 and it seems to capture when I highlight a group of cells (which contains at least one value) and then hit the delete key.
You can use the CommandBars Undo Control to determine if the user has actually deleted something.
Bear in mind this will fire if the user any or all of the contents of the Range D14:D18, but can be adjusted in many ways to suit your exact needs. After seeing your edit, this basically means you can adjust the ranges and need be and which cells in column E it affects as well. If you need more guidance on this, let me know.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Range("D14:D18")) Is Nothing Then
Dim sLastAction As String
sLastAction = Application.CommandBars("Standard").Controls("&Undo").List(1)
Debug.Print sLastAction
'manual delete 'right-click delete 'backspace delete
If sLastAction = "Clear" Or sLastAction = "Delete" Or Left(sLastAction, 9) = "Typing ''" Then
Application.EnableEvents = False
Me.Range("E14:E18").ClearContents
Application.EnableEvents = True
End If
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ChangedRange As Range
Dim Area As Range
Dim Cell As Range
Set ChangedRange = Application.Intersect(Target, Range("D:D"))
If Not ChangedRange Is Nothing Then
Application.EnableEvents = False
For Each Area In ChangedRange.Areas
For Each Cell In Area
If IsEmpty(Cell) Then
Cell.Offset(0, 1).ClearContents
End If
Next
Next
Application.EnableEvents = True
End If
End Sub
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
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
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.