I have a table from A12 to AO29. The table headers are in row13.
I am working on a macro that deletes data in column D, E and I when the cell in column B is changed or deleted. The code below works fine, except that it is not deleting the data column D. Column D has a data validation list.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = True
If Not Intersect(Target, Range("H6")) Is Nothing Then
Application.EnableEvents = False
Range("H8") = vbNullString
Range("H7") = vbNullString
Application.EnableEvents = True
End If
If Not Intersect(Target, Range("$H6")) Is Nothing Then
Range("A12:B29").ClearContents
Range("D12:E29").ClearContents
Range("I12:I29").ClearContents
Range("A33:F50").ClearContents
Range("J33:J50").ClearContents
Range("A54:H71").ClearContents
Range("L54:L71").ClearContents
Range("A75:H92").ClearContents
Range("L75:L92").ClearContents
Range("A96:E113").ClearContents
Range("I96:I113").ClearContents
Range("A117:B134").ClearContents
Range("F117:F134").ClearContents
Range("A138:C156").ClearContents
Range("G138:G159").ClearContents
Range("A160:C177").ClearContents
Range("G160:G177").ClearContents
Range("A181:C198").ClearContents
Range("G181:G198").ClearContents
End If
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("A12:A29")) Is Nothing Then
On Error GoTo haveError
Application.EnableEvents = False
If Target.Column = 1 Then Target.Offset(0, 1).clearcontent
Target.EntireRow.Range("B1,D1,E1,I1").ClearContents
Application.EnableEvents = True
End If
If Not Intersect(Target, Range("B12:B29")) Is Nothing Then
On Error GoTo haveError
Application.EnableEvents = False
If Target.Column = 1 Then Target.Offset(0, 1).clearcontent
Target.EntireRow.Range("D1,E1,I1").ClearContents
End If
If Not Intersect(Target, Range("D12:D29")) Is Nothing Then
On Error GoTo haveError
Application.EnableEvents = False
If Target.Column = 1 Then Target.Offset(0, 1).clearcontent
Target.EntireRow.Range("E1,I1").ClearContents
End If
If Not Intersect(Target, Range("E12:E29")) Is Nothing Then
On Error GoTo haveError
Application.EnableEvents = False
If Target.Column = 1 Then Target.Offset(0, 1).clearcontent
Target.EntireRow.Range("I1").ClearContents
Application.EnableEvents = True
End If
Exit Sub
haveError:
Application.EnableEvents = True
This would be easier to manage:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, _
Me.Range("A12:B29,D12:D29,E12:E29")) Is Nothing Then
On Error GoTo haveError
Application.EnableEvents = False
For Each c in Target.EntireRow.Range("B1,D1,E1,I1").Cells
If c.Column > Target.Column Then c.ClearContents
Next c
Application.EnableEvents = True
End If
Exit Sub
haveError:
Application.EnableEvents = True
End Sub
Note when using Range() in the context of EntireRow, the range is relative to the single row.
When you're checking the b12-b29 range, you're not unionizing your ranges so the call to clear contents only affects the last range you set it to which would be the i column.
You could also condense this down drastically by replacing it with one line like this
If Not Intersect(Target, Range("b12", "b29")) Is Nothing Then
Set rngDB = Union(Range("d" & Target.Row), Range("e" & Target.Row), Range("i" & Target.Row))
rngDB.ClearContents
End If
Related
By using Concatenate to combine 6 entries and then evaluate them, my worksheet changes the value of cell AA1 to be greater than 1 when a duplicate entry of any other row has been made. The Excel formula works well, but I need help on the VBA side: The code below is part of a Private Sub Worksheet_Change(ByVal Target As Range) with many operations that continue to work perfectly, while this does nothing at all. I already have Conditional Formatting highlighting the duplicate row entries, but I need a msg box to tell users what they have done wrong and how to fix it.
Dim fng As Range
Set fng = Range("$AA$1")
If Not Intersect(Target, fng) Is Nothing Then
If Target.Value > 1 Then
MsgBox "You already entered this barrel -- Enter another barrel over the duplicate. If no more barrels, change Grade to X, amounts to 0, and Producer to Z ZZ", vbOKOnly, "OOPS!"
End If
End If
In case it makes more sense to see the entire code, he it is:
Private Sub Worksheet_Change(ByVal Target As Range)
Target.Worksheet.Unprotect Password:="Cami8"
Dim rng As Range
Set rng = Range("F3:F10001")
If Not Intersect(Target, rng) Is Nothing Then
Target.Offset(0, 4) = Now
ActiveWorkbook.Save
End If
Application.EnableEvents = True
Dim ung As Range
Set ung = Range("J3:J10005")
If Not Intersect(Target, ung) Is Nothing Then
Target.Offset(-1, -3).Locked = True
End If
Application.EnableEvents = True
Dim wng As Range
Set wng = Range("J3:J10005")
If Not Intersect(Target, wng) Is Nothing Then
Target.Offset(-1, -4).Locked = True
End If
Application.EnableEvents = True
Dim xng As Range
Set xng = Range("J3:J10005")
If Not Intersect(Target, xng) Is Nothing Then
Target.Offset(-1, -5).Locked = True
End If
Application.EnableEvents = True
Dim kng As Range
Set kng = Range("J3:J10005")
If Not Intersect(Target, kng) Is Nothing Then
Target.Offset(-1, -6).Locked = True
End If
Application.EnableEvents = True
Dim qng As Range
Set qng = Range("J3:J10005")
If Not Intersect(Target, qng) Is Nothing Then
Target.Offset(-1, -7).Locked = True
End If
Application.EnableEvents = True
Dim cng As Range
Set cng = Range("C3:E10001")
If Not Intersect(Target, cng) Is Nothing Then
Application.EnableEvents = False
Target.Value = UCase(Target.Value)
Target.NumberFormat = "General"
Application.EnableEvents = True
End If
Dim sng As Range
Set sng = Range("E3:E10002")
If Not Intersect(Target, sng) Is Nothing Then
If Len(Target) > 1 Then
MsgBox "You entered GRADE with a letter and a space -- Click on the cell and enter only a letter", vbOKOnly, "OOPS!"
End If
End If
Dim fng As Range
Set fng = Range("$AA$1")
If Not Intersect(Target, fng) Is Nothing Then
If Target.Value > 1 Then
MsgBox "You already entered this barrel -- Enter another barrel over the duplicate. If no more barrels, change Grade to X, amounts to 0, and Producer to Z ZZ", vbOKOnly, "OOPS!"
End If
End If
Target.Worksheet.Protect Password:="Cami8"
End Sub
Thanks for the great tip about Worksheet_Calculate, since that did the trick! I just removed the code I had in Worksheet_Change and input this:
Private Sub Worksheet_Calculate()
Const lVal As Long = 2
Dim rCell As Range
Set rCell = Range("AA1")
If rCell.Value = lVal Then
MsgBox "You already entered this barrel -- Enter another barrel over the duplicate. If no more barrels, change Grade to X, amounts to 0, and Producer to Z ZZ", vbOKOnly, "OOPS!"
End If
End Sub
Having trouble executing both Worksheet_Change events correctly. Image below show my results, when modifying column B, column M does nothing. When modifying column L, column N updates as expected but only on row 2. Every other subsequent change to B or M results in N:2 updating to the current time again.
My desired outcome is that when Col B is updated I record a time stamp in Col M and the same when Col L updates that I get a time stamp in Col N.
Example of Excel Error
My current code is here:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim rng As Range
Dim rng2 As Range
If Not Intersect(Target, Columns("B"), Target.Parent.UsedRange) Is Nothing Then
On Error GoTo Safe_Exit
For Each rng In Intersect(Target, Columns("B"), Target.Parent.UsedRange)
If CBool(Len(rng.Value2)) And Not CBool(Len(rng.Offset(0, 11).Value2)) Then
rng.Offset(0, 11) = Now
ElseIf Not CBool(Len(rng.Value2)) And CBool(Len(rng.Offset(0, 11).Value2)) Then
rng.Offset(0, 11) = vbNullString
End If
Next rng
Application.EnableEvents = True
End If
ElseIf Not Intersect(Target, Columns("L"), Target.Parent.UsedRange) Is Nothing Then
On Error GoTo Safe_Exit
For Each rng2 In Intersect(Target, Columns("L"), Target.Parent.UsedRange)
If CBool(Len(rng2.Value2)) And Not CBool(Len(rng2.Offset(0, 2).Value2)) Then
rng2.Offset(0, 2) = Now
ElseIf Not CBool(Len(rng2.Value2)) And CBool(Len(rng2.Offset(0, 2).Value2)) Then
rng2.Offset(0, 2) = vbNullString
End If
Next rng2
Application.EnableEvents = True
End If
Safe_Exit:
End Sub
Mock-up, untested, change of code to simplify as you're doing the same actions in two spots:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim columnLetter as String
Select Case Target.Column
Case 2 'B
columnLetter = "M"
Case 12 'L
columnLetter = "N"
Case Else
Goto Safe_Exit
End Select
Dim loopRng as Range
For Each loopRng In Range(Cells(Target.Row, Target.Column),Cells(Target.End(xlDown).Row,Target.Column)
If IsEmpty(loopRng) = True And IsEmpty(Cells(loopRng.Row,columnLetter)) = False Then
Cells(loopRng.Row,columnLetter) = Now
ElseIf IsEmpty(loopRng) = False And IsEmpty(Cells(loopRng.Row,columnLetter)) = True Then
Cells(loopRng.Row,columnLetter) = vbNullString
End If
Next loopRng
'Columns(columnLetter).NumberFormat = "yyyy/mm/dd"
Application.EnableEvents = True
Safe_Exit:
Application.EnableEvents = True
End Sub
Note that the IsEmpty() = True is important... when using an If case, you need to specify for each condition, otherwise the implicit detection will fail.
Edit1: Removed Intersect from loop, whereas the range i've listed will need corrected... it at least references a specific range, now.
Edit2: Removing .Offset and working with specific column references in cells().
I tried this version of my original code and it started to work for some reason.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns("B"), Target.Parent.UsedRange) Is Nothing Then
On Error GoTo Safe_Exit
Application.EnableEvents = False
Dim rng As Range
For Each rng In Intersect(Target, Columns("B"), Target.Parent.UsedRange)
If CBool(Len(rng.Value2)) And Not CBool(Len(rng.Offset(0, 11).Value2)) Then
rng.Offset(0, 11) = Now
ElseIf Not CBool(Len(rng.Value2)) And CBool(Len(rng.Offset(0, 11).Value2)) Then
rng.Offset(0, 11) = vbNullString
End If
Next rng
End If
If Not Intersect(Target, Columns("L"), Target.Parent.UsedRange) Is Nothing Then
On Error GoTo Safe_Exit
Application.EnableEvents = False
For Each rng In Intersect(Target, Columns("L"), Target.Parent.UsedRange)
If CBool(Len(rng.Value2)) And Not CBool(Len(rng.Offset(0, 2).Value2)) Then
rng.Offset(0, 2) = Now
ElseIf Not CBool(Len(rng.Value2)) And CBool(Len(rng.Offset(0, 2).Value2)) Then
rng.Offset(0, 2) = vbNullString
End If
Next rng
End If
Safe_Exit:
Application.EnableEvents = True
End Sub
I want a macro that automatically multiplies a given column by a set number. This number will be different for each column. I am only able to apply it to one column so far. I can't have it done for any other:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B:B")) Is Nothing Then Exit Sub
Application.EnableEvents = False
Target.Value = Target.Value * 300
Application.EnableEvents = True
If Intersect(Target, Range("C:C")) Is Nothing Then Exit Sub
Application.EnableEvents = False
Target.Value = Target.Value * 500
Application.EnableEvents = True
End Sub
Perhaps like this:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.CountLarge > 1 Then Exit Sub
On Error GoTo SafeExit
Application.EnableEvents = False
Dim rng As Range
Set rng = Intersect(Target, Me.Range("B:B")
If Not rng Is Nothing Then
rng.Value = rng.Value * 300
End If
Set rng = Intersect(Target, Me.Range("C:C"))
If Not rng Is Nothing Then
rng.Value = rng.Value * 500
End If
SafeExit:
Application.EnableEvents = True
End Sub
EDIT:
This is probably a better approach if you have more than two columns (and they are contiguous):
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Range("B:F")) Is Nothing Then
On Error GoTo SafeExit
Application.EnableEvents = False
Dim rng as Range
For Each rng In Intersect(Target, Me.Range("B:F"))
Dim multiplier As Long
Select Case rng.Column
Case 2 ' column B
multiplier = 300
Case 3 ' column C
multiplier = 500
Case 4 ' column D
multiplier = 400
Case 5 ' column E
multiplier = ...
Case 6 ' column F
multiplier = ...
End Select
If IsNumeric(rng.Value) Then
rng.Value = rng.Value * multiplier
End If
Next
End If
SafeExit:
Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Const Col As Long = 2
If Not Intersect(Target, Range("L7:L98")) Is Nothing Then
Application.EnableEvents = False
Target.Value = "T"
Target.Offset(, 1).Resize(, Col).ClearContents
Application.EnableEvents = True
End If
If Not Intersect(Target, Range("M7:M98")) Is Nothing Then
Application.EnableEvents = False
Target.Value = "I"
Target.Offset(, 1).ClearContents
Target.Offset(, -1).ClearContents
Application.EnableEvents = True
End If
If Not Intersect(Target, Range("N7:N98")) Is Nothing Then
Application.EnableEvents = False
Target.Value = "D"
Range(Target.Offset(, -1), Target.Offset(, -2)).ClearContents
Application.EnableEvents = True
End If
End Sub
This code is causing a slight problem for me. Any time I select an entire row within the ranges, every cell within the range gets changed to "T". Given the consistency of the code, if I delete the string with "T", then the entire row would be filled with "I"
What can be adjusted to trigger only if cells within the range are selected?
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Const Col As Long = 2
If Target.Count > 1 Then
Exit Sub
End If
Added this to the top of the code, it will now exit the Sub if more than one cell is selected even if one of the selected cells are within the appropriate range.
After checking to see if the Selection intersects with the various ranges, only deal with the part of Target that intersects with the various ranges.
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Const Col As Long = 2
If Not Intersect(Target, Range("L7:L98")) Is Nothing Then
Application.EnableEvents = False
With Intersect(Target, Range("L7:L98"))
.Value = "T"
.Offset(, 1).Resize(, Col).ClearContents
End With
End If
If Not Intersect(Target, Range("M7:M98")) Is Nothing Then
Application.EnableEvents = False
With Intersect(Target, Range("M7:M98"))
.Value = "I"
.Offset(, 1).Resize(, Col).ClearContents
End With
End If
If Not Intersect(Target, Range("N7:N98")) Is Nothing Then
Application.EnableEvents = False
With Intersect(Target, Range("N7:N98"))
.Value = "D"
.Offset(, 1).Resize(, Col).ClearContents
End With
End If
Application.EnableEvents = True
End Sub
Optional Alternative:
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Const Col As Long = 2
If Not Intersect(Target, Range("L7:L98")) Is Nothing Then
Application.EnableEvents = False
With Intersect(Target, Range("L7:L98"))
.Value = "T"
.Offset(, 1).Resize(, Col).ClearContents
End With
ElseIf Not Intersect(Target, Range("M7:M98")) Is Nothing Then
Application.EnableEvents = False
With Intersect(Target, Range("M7:M98"))
.Value = "I"
.Offset(, 1).Resize(, Col).ClearContents
End With
ElseIf Not Intersect(Target, Range("N7:N98")) Is Nothing Then
Application.EnableEvents = False
With Intersect(Target, Range("N7:N98"))
.Value = "D"
.Offset(, 1).Resize(, Col).ClearContents
End With
End If
Application.EnableEvents = True
End Sub
Got a problem and looking for some advice. I've been using the below code for a while now in Excel, it clears the contents of column B if cell A is empty. It works great, but I now need it to work for a specific range (A6:B35). Any ideas?
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Column = 1 Then
If Target.Validation.Type = 3 Then
Application.EnableEvents = False
Target.Offset(0, 1).ClearContents
End If
End If
exitHandler:
Application.EnableEvents = True
Exit Sub
End Sub
You need to test if the active cell (target) falls in the range A6:A35. Like this:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If not intersect(target, range("A6:A35")) is nothing then
If Target.Validation.Type = 3 Then
Application.EnableEvents = False
Target.Offset(0, 1).ClearContents
Application.EnableEvents = True
End If
End if
exitHandler:
End Sub
You should also indent your code so it is more readable. It will help with loops and IF statements.
something like
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng1 As Range
Dim rng2 As Range
Set rng1 = Intersect(Target, Range("A6:B35"))
If rng1 Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each rng2 In rng1
If rng2.Validation.Type = 3 Then rng2.Offset(0, 1).ClearContents
Next
Application.EnableEvents = True
End Sub