Why isn't this msg box code working when Target.Value >1 - excel

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

Related

How to combine two different request for two different columns in excel VBA

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

Why are my attempts at creating a dynamic vba range for only the first section of data failing?

To protect a second section of dynamic data when rows are removed in the first section, I need to change the last section of existing code below to a dynamic range that begins at E3 and ends either at the first row where column E is blank, last row where it is => zero or use a dynamic cell reference (N2) that shows # of last row (or anything that will work). At present, I handle this new need by manually changing E10001 to the new end of the first section of data (i.e, E5006). All of my attempts (used every option I could find) at this dynamic code resulted in the date being inserted 3 columns to right of any entry I make in my test spreadsheet. Thanks in advance for any help.
Private Sub Worksheet_Change(ByVal Target As Range)
Target.Worksheet.Unprotect Password:="Midnight"
On Error Resume Next
Application.EnableEvents = True
Dim hng As Range
Set hng = Range("F3:F10001")
If Intersect(Target, hng) Is Nothing Then
Target.Offset(-1, -4).Locked = True
End If
Application.EnableEvents = True
Dim xng As Range
Set xng = Range("F3:F10001")
If Intersect(Target, xng) Is Nothing Then
Target.Offset(-1, -3).Locked = True
End If
Application.EnableEvents = True
Dim wng As Range
Set wng = Range("F3:F10001")
If Intersect(Target, wng) Is Nothing Then
Target.Offset(-1, -2).Locked = True
End If
Application.EnableEvents = True
Dim qng As Range
Set qng = Range("F3:F10001")
If Intersect(Target, qng) Is Nothing Then
Target.Offset(-1, -1).Locked = True
End If
Application.EnableEvents = True
Dim sng As Range
Set sng = Range("F3:F10001")
If Intersect(Target, sng) Is Nothing Then
Target.Offset(-1, 0).Locked = True
End If
Dim cng As Range
Set cng = Range("B3:C10001")
If Not Intersect(Target, cng) Is Nothing Then
Application.EnableEvents = False
Target.Value = UCase(Target.Value)
Application.EnableEvents = True
End If
Dim rng As Range
Set rng = Range("E3:E10001")
If Not Intersect(Target, rng) Is Nothing Then
Target.Offset(0, 3) = Now
End If
Target.Worksheet.Protect Password:="Midnight"
End Sub
I am concluding that this is not possible. I have created a workaround using reference to calculated values in another sheet to fill the cells not needed with null data.

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

Excel VBA script for finding specific text

So I'm adding a picture so you can see exactly what I need it to do -Excel sheet picture
So I have this script:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range, G, L, N As Range, Inte As Range, r As Range
Set A = Range("F:F,K:K,M:M")
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
We will talk about only what we see in the picture: so now when I write anything in column F it gives the date in column G, I want that it will give the date only if I write "Ja" (Yes in German) or "Yes"
Simple is that. I tried to find any "if" commands for it but none of mine worked.
Hope you can help me with that
Thanks!
Daniel
Here is a better practice to achieve that also you need to set Application.EnableEvents back to True when you are existing the method for the next time the event will be raised, also its not bad to make some "house keeping" and use error catch if something goes wrong:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ende
Application.EnableEvents = False
Set A = Range("F:F,K:K,M:M")
Set Inte = Intersect(A, Target)
If Inte Is Nothing Then
Application.EnableEvents = True
Exit Sub
End If
For Each cel In Target
r = cel.Row
c = cel.Column
If Trim(LCase(Cells(r, c))) = "yes" Or Trim(LCase(Cells(r, c))) = "ja" Then
Cells(r, c + 1) = Format(Date, "dd.MM.yyyy")
Else
' do something else
End If
Next
ende:
Application.EnableEvents = True
End Sub
What about this?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Dim rng As Range
Set rng = Range("F:F,K:K,M:M")
On Error GoTo SkipError
Application.EnableEvents = False
If Not Intersect(Target, rng) Is Nothing Then
For Each cell In Target
If LCase(VBA.Trim(cell.Value)) = "yes" Then
cell.Offset(0, 1) = Date
End If
Next cell
End If
SkipError:
Application.EnableEvents = True
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