Combining 2 vba codes over 2 different ranges into one statement - excel

I can make one or the other of the below codes work, but need them both. The first locks cells in range upon data entry, the second inserts a date stamp when the final data entry in column D of each row is completed.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xRg As Range
On Error Resume Next
Set xRg = Intersect(Range("A8:D5005"), Target)
If xRg Is Nothing Then Exit Sub
Target.Worksheet.Unprotect Password:="Midnight"
xRg.Locked = True
Target.Worksheet.Protect Password:="Midnight"
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Set rng = Range("D8:D5005")
If Not Intersect(Target, rng) Is Nothing Then
Target.Offset(0, 1) = Now
Target.Offset.NumberFormat = "dd/mm/yyyy hh:mm:ss"
End If
End Sub

I'm still guessing a bit exactly what you're trying to do … but here is way to allow your users enter four data points ... and then to press button to add the data points to a protected list … and includes a time stamp.
First setup 4 data entry cells in A4 through to D4 by using the Format Cell option, make sure for these cells that Locked is unchecked on the Protection tab.
Next create a button and link the button to the following code:
Sub ButtonCode()
ActiveSheet.Unprotect Password:="A"
Range("A7:E7").Insert xlShiftDown
Range("A4:D4").Copy Range("A7:D7")
Range("E7") = Now()
Range("A7:E7").Interior.Color = rgbLightBlue
Range("A7:E7").Font.Color = rgbBlack
ActiveSheet.Protect Password:="A"
End Sub
As a once only step, protect the worksheet; my example consistently uses a password of "A". Note that your users will not need to enter the password at any time.
Once the sheet is setup, when the button is clicked, the code unlocks the sheet (allowing it to make edits), it move the existing data data down, copy the new data points to the top of the list, adds timestamp and some minimal formatting. It then re-enables protection so that the user can't overwrite the existing entries.
The screenshot below gives you an idea of what it might look like, including showing that A4:D4 need to be unlocked.
Maybe not the implementation direction you were thinking of … but the principles included in this example might work for you. All the best.

I'm not 100% sure of the structure of your worksheet, so here are the assumptions for my response. You only want the user to modify cells in the range "A8:D5005" … and somewhere on the sheet you want to record date/timestamp changes for cells changed.
So I would start by protecting the sheet by going to the Excel "Review" ribbon (not in VBA), and setting up an editable range as follows.
Before you close the dialog box, click on Protect Sheet so that the rest of the sheet is password protected.
Once you've done this … you can use something like the code below to record the date/timestamps. In this example … I record them in columns to the right of your editable range (given your editable data is only to Column D).
Private Sub Worksheet_Change(ByVal Target As Range)
Dim vIntersect As Variant
Set vIntersect = Application.Intersect(Target, Range("A8:D5005"))
If Not vIntersect Is Nothing Then
Application.EnableEvents = False
Target.Worksheet.Unprotect Password:="Midnight"
Target.Offset(0, 5) = Now
Target.Offset(0, 5).NumberFormat = "dd/mm/yyyy hh:mm:ss"
Target.Worksheet.Protect Password:="Midnight"
Application.EnableEvents = True
End If
End Sub

Related

Trigger Macro only when Cell Value is Increased

its me....again. I am currently trying to have a Macro trigger whenever a specific cell increases on a specific sheet.
After many attempts I have been able to get the Macro to trigger when the cell is changed (increasing or decreasing) but I cannot figure out a way to have this Macro trigger only when the specified cell increases in value.
I have tried to use simple Worksheet_Change with an If Then statement that calls the Macro when the cell value is changed. Again I can't get this to trigger only when the cell increases. Not sure it is possible or if I am even thinking about this is in the right way.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address "Range" Then
Call MyMacro
End If
End Sub
Thank you for any help in advance. This would be really neat and save alot of manual clicking around.
Here is the functioning Macro that I want to trigger when certain text is entered into a range.
Sub Auto_Print_Yellow_Caution()
Application.ScreenUpdating = False
Sheets("Saver").Shapes("Group 6").Copy
Sheets("Main").Select
ActiveCell.Offset(-1, 0).Select
ActiveSheet.Paste
ActiveCell.Select
Application.ScreenUpdating = True
End Sub
I already have my Workbook set up to track these words/phrases and return either a TRUE or FALSE value. If TRUE the associated Order Number is Printed into a Cell and a COUNTIFS formula is used to keep track of how many orders meet the TRUE condition. That number is then used to keep track of how many total of those orders there are. That works using the following
=IF(ISNUMBER(SEARCH("Completed",Main!G7)),TRUE)
-looks for specific word and returns TRUE
=IF(T3=TRUE,Main!A7,"")
-Returns order number
=IF(COUNTIF($U3:$U$200,"?*")<ROW(U3)-2,"",INDEX(U:U,SMALL(IF(U$2:U$200<>"",ROW(U$2:U$200)),ROWS(U$2:U3))))
-Sorts order numbers into list
=COUNTIF(T2:T135,TRUE)
-Counts number of orders
Hopefully this adds context to what I am trying to accomplish.
This will hopefully get you on the right track. As per your question it assumes this is required for a single cell only (and in this example code, that cell is B2). The trick is to store the new value, 'undo' the change, grab the old value, reverse the 'undo' by replacing the new value. Then you can test if the values are numbers and, if so, test if the new number is greater than the old number.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim newValue As Variant, oldValue As Variant
If Target Is Nothing Then Exit Sub
If Target.Cells.Count <> 1 Then Exit Sub
If Target.Column <> 2 Or Target.Row <> 2 Then Exit Sub ' example is using cell B2
Application.EnableEvents = False
newValue = Target.Value2
Application.Undo
oldValue = Target.Value2
Target.Value2 = newValue
Application.EnableEvents = True
If IsNumeric(oldValue) And IsNumeric(newValue) Then
If CDbl(newValue) > CDbl(oldValue) Then
Call MyMacro
End If
End If
End Sub
Here is some logic I can think of, you need to have a helper cell to store previous data and compare if it increased. In this sample my helper cell is B1 and the cell I want to track is A1
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KCells As Range
Set KCells = Sheet10.Range("A1")' The variable KeyCells contains the cells that will
If Not Application.Intersect(KCells, Range(Target.Address)) Is Nothing Then 'cause an alert when they are changed.
If Sheet10.Range("B1").Value < Sheet10.Range("A1").Value Then
MsgBox "Replace this to call macro"
Sheet10.Range("B1").Value = Sheet10.Range("A1").Value 'this is to save the current data incase you change it later.
End If
End If
End Sub

How to lock cells which are automated filled

I want to lock the cell after entering a value in it. When I change the value on sheet2 A1, the value should still be locked in B2.
When I enter "3" in Sheet2 A1 the number 2 should till be there.
Here the code I already have:
Private Sub Worksheet_Change(ByVal Target As Range)
Sheet1.Unprotect "1234"
If VBA.IsEmpty(Target.Value) Then
Target.Locked = False
Else
Target.Locked = True
End If
Sheet1.Protect "1234"
End Sub
My first answer was assuming that cell Locking referred to the Range.Locked property but now I understand that was intended to refer to the cell values and preventing them from recalculating.
There are a few techniques that can be used to prevent cells from recalculating. The easiest would be to just change any formulas into a static value like:
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Target.Value = Target.Value
Application.EnableEvents = True
End Sub
This event will get rid of every formula after it calculates its value the first time. Every cell will just be whatever value the user enters or whatever value the formula calculates the first time.
You can limit the range that the event will operate within by using Intersect like:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim OperationalArea As Range, AffectedArea As Range
Set OperationalArea = Me.Range("B2:F10")
Set AffectedArea = Intersect(Target, OperationalArea)
If Not AffectedArea Is Nothing Then
Application.EnableEvents = False
AffectedArea.Value = AffectedArea.Value
Application.EnableEvents = True
End If
End Sub
This would limit the event to only change cells within the area "B2:F10" as defined in OperationalArea.
If you don't like this idea you can try messing about with Application.Calculation but it gets very messy when you have multiple sheets or workbooks open.
When you do Worksheet.Protect, every cell is locked by default. You need to specify which cells should still be editable (not locked) after protecting the sheet. In your case, you need to specify that every cell except your chosen few are not locked.
The second important note is that Worksheet.Protect has an option UserInterfaceOnly which when true, allows macros to continue editing cells without needing to unprotect the sheet first. This means you can leave the sheet protected and just unlock or lock cells as needed.
Here is an example of how to unlock every cell except A1 on Sheet1:
Sub Example()
With Sheet1
.Protect Password:="1234", UserInterfaceOnly:=True
.Cells.Locked = False
.Cells(1, 1).Locked = True
End With
End Sub

Add a Value Automatically to a Cell Based on Another Cell

I want to add a value to a cell based on another with VBA but I'm not sure how. I already searched on internet about it but can't find anything.
I have a table, and on the Column C, if any cell contains the text "MAM" (because it might have MAM-565), then change the value from Cell A to "Wrong", but if it contains "NAC", then change value to "Correct". It should be in the same row as the text found.
Also, I want to add the date automatically to cell E every time Cell in D is filled.
This the code I have already:
Private Sub Worksheet_Change(ByVal Target As Range)
'Add Issue Type'
Dim Code As Range
Set Code = Range("C2:C100000")
For Each Cell In Code
If InStr(1, Cell, "NAC") Then
Range("A2:A10000").Value = "Correct"
ElseIf InStr(1, Cell, "MAM") Then
Range("A2:A10000").Value = "Wrong"
End If
Next
End Sub
This how my table looks like:
Table
Thanks in advance guys :)
To automatically add the datestamp:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng as Range
Set rng = Intersect(Target, Me.Range("D:D"))
If rng Is Nothing Then Exit Sub
On Error GoTo SafeExit
Application.EnableEvents = False
Dim cell as Range
For Each cell in rng
If Not IsEmpty(cell) Then ' don't do anything if cell was cleared
cell.Offset(,1).Value = Date
End If
Next
SafeExit:
Application.EnableEvents = True
End Sub
As far as the Correct/Wrong, this can easily be done with a formula (ISNUMBER(SEARCH(...)). I don't see the need for VBA here.
Even better, create a table using Ctrl+T. Excel will automatically add the formula in column A in new rows.

Remove Validation Rules Row by Row from Sheet Based on Column G Value

Hy Experts, I am using an excel sheet that has multiple columns. Every column has validation rules. I want to remove these validation rules upon selecting any row in the entire sheet. When I select the row then I will put the value in G from drop down menu. on the basis of column G value the entire row validation rules should be cleared. The sheet looks like this.
enter image description here
The code that I am using is as under.
Sub RemoveDV()
Dim ws As Worksheet
For Each ws In Worksheets
ws.Cells.Validation.Delete
Next ws
MsgBox ("All Validation Rules has been removed successfully")
End Sub
it working fine but it delete the entire worksheet. But I want to delete the validation only row that I am working on.
Thanks
Try this:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Debug.Print Target.Address
If Not Intersect(Target, Range("G:G")) Is Nothing And Target.Count = 1 Then
If Target.Value = "The value that will trigger the validation clearing" Then
Target.EntireRow.Validation.Delete
End If
End If
End Sub
This will trigger anytime you change a value in column "G" of the specified sheet and if the new value = the text you want.
EDIT:
Let say you store your values (values that will trigger the script) in a range on the same page you can adapt following code to your needs:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Arr: Arr = Application.Transpose(Range("$P$1:$P$12").Value) 'Values stored in "P1:P12"
If Not Intersect(Target, Range("G:G")) Is Nothing And Target.Count = 1 Then
If UBound(Filter(Arr, Target.Value)) > -1 Then
Target.EntireRow.Validation.Delete
End If
End If
End Sub

How to prevent pasting over validation drop down cell in Excel VBA

I need to stop the user from pasting over my validation drop down cell. I have read and tried various solutions, none of which work just right. This code I have checks if the pasted value follows validation rules, but it doesn't work if the entire cell is pasted over my validation cell (it seems that this event fires after the paste, so the validation gets erased together with the previous cell):
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cell As Range
For Each Cell In Range("D2:F13")
If Not Cell.Validation.Value Then
MsgBox "Value violates validation rule"
Application.Undo
Exit Sub
End If
Next
Ideally the code would check if the value of the cell that's being pasted matches validation dropdown options and only allows to paste the value (not the formatting) into the cell.
Thanks!
You can disable the Cut\Copy in the specific cell:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' TARGET IS YOUR VALIDATION CELL
If Target.Column = 1 And Target.Row = 1 Then
Application.CutCopyMode = False
End If
End Sub
Or more complex you can try to check the clipboard of the user on SelectionChange
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' TARGET IS YOUR VALIDATION CELL
If Target.Column = 1 And Target.Row = 1 Then
Set MyData = New DataObject
MyData.GetFromClipboard
'In MyData.GetText you have the clipboard data in text format
If MyData.GetText <> "what you want" then
'...
End if
End If
End Sub
In this case you must add a reference to Microsoft Forms 2.0 Object Library. You can find it in this path: C:\Windows\System32\FM20.DLL

Resources