I'm looking to detect and run a certain function in VBA once all the cells in range G4:G7 have changed. I've seen many posts detecting when ONE of the cells in range have changed, whereas I want to detect once ALL of them have changed. Thanks! Hopefully someone can help me, I'm in quite a pickle.
Try this code please. It must be copied in the sheet module, like its Change event:
Private Sub Worksheet_Change(ByVal Target As Range)
Static arrChng As Variant, boolOver As Boolean
Dim rng As Range, ans As VbMsgBoxResult
Set rng = Range("G4:G7") 'the range can be extended down ("G4:G10", for instance)
'without other code modifications..
If Not Intersect(Target, rng) Is Nothing Then
If IsEmpty(arrChng) Then
arrChng = rng.Value
End If
If boolOver Then
ans = MsgBox("All values in range """ & rng.address & """ have been changed!" & _
vbCrLf & "The input value will be reversed..." & vbCrLf & vbCrLf & _
"Would you like to reset the range?", vbYesNo, "No changes allowed")
If ans = vbYes Then arrChng = Empty: boolOver = False
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
Exit Sub
End If
arrChng(Target.row - (rng.row - 1), 1) = "Changed"
If UBound(Filter(Application.Transpose(Application.Index(arrChng, 0, 1)), _
"Changed", True)) = UBound(arrChng, 1) - 1 Then
boolOver = True
MsgBox "All values in range """ & rng.address & """ have been changed!" & vbCrLf & _
"No more changes allowed.", vbInformation, "No changes allowed"
End If
End If
End Sub
It will warn when the last cell has been changed and at the next changing attempt it works again, but reversing the input to the previous cell value, asking for reset, too.
Related
what am I doing wrong here...please help, thanks PG
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ValidatedCells As Range
Dim ValidatedCells2 As Range
Dim Cell As Range
Set ValidatedCells = Intersect(Target, Target.Parent.Range("G:G"))
Set ValidatedCells2 = Intersect(Target, Target.Parent.Range("H:H"))
Application.EnableEvents = False
If Not ValidatedCells Is Nothing Or Not ValidatedCells2 Is Nothing Then
For Each Cell In ValidatedCells
If Not Len(Cell.Value) <= 20 Then
MsgBox "The Name """ & Cell.Value & _
""" inserted in " & Cell.Address & _
" in column G was longer than 20. Undo!", vbCritical
Application.Undo
End If
Next Cell
For Each Cell In ValidatedCells2
If Not Len(Cell.Value) <= 50 Then
MsgBox "The Name """ & Cell.Value & _
""" inserted in " & Cell.Address & _
" in column H was longer than 50. Undo!", vbCritical
Application.Undo
Next Cell
Exit Sub
End If
Application.EnableEvents = True
End Sub
I tried above and not sure if it is the syntax or if the loop statements are incorrect, please help
A few issues in your code - after calling Undo there's no point in continuing, so you can just exit at that point. Needs some error handling to make sure Events are not left turned off.
I'd maybe do something like this:
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo done
If TooLong(Intersect(Target, Me.Range("G:G")), 20) Then GoTo done
If TooLong(Intersect(Target, Me.Range("H:H")), 50) Then GoTo done
done:
If Err.Number <> 0 Then MsgBox Err.Description 'in case of error
Application.EnableEvents = True
End Sub
'If any cell in range `Monitored` has content longer than `maxLen`,
' call Undo and return True
Function TooLong(Monitored As Range, maxLen As Long) As Boolean
Dim c As Range
If Not Monitored Is Nothing Then
For Each c In Monitored.Cells
If Len(c.Value) > maxLen Then
MsgBox "The Name """ & c.Value & """ inserted in " & c.Address & _
" in column was longer than " & maxLen & ". Undo!", vbCritical
Application.EnableEvents = False
Application.Undo
TooLong = True
Exit Function
End If
Next c
End If
End Function
Note: in a worksheet code module you can use Me to refer to the worksheet, instead of Target.Parent
just starting out with VBA and got stuck on this issue;
I have a resource sheet for people/equipment. The available equipment rows are lower in the sheet than the main work plan. I want to be able to select an item of equipment from the work plan and return it to the available equipment rows. The code below is what I have so far but it's not working. Not sure if it's because I have asked it to select activecell for 2 ranges?
Rng1 is the cell I want to move.
Rng2 is in the same column as Rng1 but lower down (I am trying to reference Rng1 with the same value in Column A to select the correct row).
Hope that all makes sense :)
Public Sub Return_Equipment()
Dim Name1 As String, Name2 As String, NameTemp As String, NameRef As String, Rng1 As Range, Rng2 As Range, Rng3 As Range, StatusVar As Boolean
If IsEmpty(ActiveCell) Then
MsgBox "Please select an item of equipment", vbOKOnly + vbInformation, "Selection Error"
Exit Sub
End If
On Error GoTo errorhandler
Set Rng1 = ActiveCell
Do
NameRef = Intersect(ActiveCell.EntireRow, ActiveCell.CurrentRegion.Columns(1)).Value
If (ActiveCell.Value = NameRef) = False Then
ActiveCell.Offset(1, 0).Select
End If
Loop Until (ActiveCell.Value = NameRef) = True
ActiveCell
Set Rng2 = ActiveCell
Set Rng3 = Application.InputBox("Please select last date for returning", Type:=8)
On Error GoTo 0
StatusVar = False
If IsEmpty(Rng2) Then
StatusVar = True
If WorksheetFunction.CountA(Range(Rng2.Address).Resize(, Range(Rng1.Address & ":" & Rng3.Address).Columns.Count)) <> 0 Then
MsgBox "Not all cells are empty in the destination row! Please start again.", vbCritical + vbOKOnly, "Cell Allocation Error"
Exit Sub
End If
End If
'...
'errorhandler:
'...
End Sub
I'll elaborate a little more regarding what I'm trying to do;
In the picture below I want to return the trailer "Trailer 37U52 L4386 (for trk Ranger)" from cells IV:114 & IW:114 to IV:261 & IW:262 and clear data from IV:114 & IW:114.
I start by selecting IV:114 and running the code. The code sets IV:114 to Rng1. Then it looks at Column A for the corresponding value (in this case A:261) and sets Rng2 as the cell in that row in the Rng1 column (IV:261). The end date is selected using the input box and sets Rng3 as the last column I want this change to be applied to (in the same row as Rng1) In this case I select a cell in column IW.
It is then supposed to relabel cells IV:261 & IW:261 with the values from IV:114 & IW:114 and clear data from IV:114 & IW:114. What I see it doing when I run the code is setting IV:114 & IW:114 to "Temp Value" and then relabeling it back to "Trailer 37U52 L4386 (for trk Ranger)"
Does that help anyone to see what is wrong with my code?
Picture of scenario
According to your description, that one should work.
It is not the cleanest version (you should mention worksheet...)
Public Sub Return_Equipment()
Dim Name1, Name2, NameRef As String
Dim Rng1, Rng2, Rng3 As Range
Dim i, j as Long
If IsEmpty(ActiveCell) Then
MsgBox "Please select an item of equipment", vbOKOnly + vbInformation, _
"Selection Error"
Exit Sub
End If
On Error GoTo errorhandler
Set Rng1 = ActiveCell
Set Rng2 = Cells(1, 1)
j = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row - Rng1.Row
For i = 1 to j
If Rng1.Value = Cells(Rng1.Row + i, 1).Value Then
Set Rng2 = Cells(Rng1.Row + i, 1)
End If
Next
If Rng2 = Cells(1, 1) Then
MsgBox "There is no match"
Exit Sub
End if
Set Rng3 = Application.InputBox("Please select last date for returning", Type:=8)
For i=0 to abs(Rng1.Column - Rng3.Column)
If Rng2.Offset(0, Rng1.Column + i).Value <> "" Then
NameRef = "Fail"
MsgBox "Not all cells are empty in the destination row! _
Please start again.", vbCritical + vbOKOnly, "Cell Allocation Error"
End If
Next
If NameRef <>"Fail" Then
For i=0 to abs(Rng1.Column - Rng3.Column)
Cells(Rng2.Row, Rng1.Column + i).Value = _
Cells(Rng1.Row, Rng1.Column + i).Value
Cells(Rng1.Row, Rng1.Column + i).Value = ""
Next
End If
...
error handler
...
End Sub
Just check on the index "i" that it is working properly, maybe it is one unit short or long. It is difficult to reproduce your sheet to test it.
Hope it helps!
When .Find does not find a result, I want an error msg. I have used the method that is almost universally recommended online, but it is not working. When a value is not found, nothing happens. There should be a msg box identified the error.
If Not rFoundCell Is Nothing Then
MsgBox "val: " & rValue.Value & " Matching Cell: " & rFoundCell.Address
Cells(Range(rFoundCell.Address).Row, Range(rFoundCell.Address).Column).Select
Else
MsgBox (rValue.Value & " not found.")
GoTo end_search
End If
I've tried the other way as well:
If rFoundCell Is Nothing Then
Display a msg "not found"
else
Keep going.
That didn't work either. What am i missing?
Full code follows:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim PostRng As Range
Dim PendRng As Range
Dim rValue As Range
Dim lLoop As Long
Dim rFoundCell As Range
Dim INTRng As Range
Set PostRng = Range("g:g")
Set PendRng = Range("k:k")
'"Intersect" will ensure your current cell lies on correct column.
Set INTRng = Intersect(Target, PostRng)
'IF conditions to trigger code.
'This IF confirms only one cell changed. -- I think
If Target.Columns.Count = 1 And Target.Rows.Count = 1 Then
If Not INTRng Is Nothing And LCase(Target.Text) = "y" Then
'This block will return the range & value on the row where "y" or "Y" are entered.
Set rValue = Target.Offset(0, -3) 'Returns value in Col D
If rValue = 0 Or rValue = "" Then Set rValue = Target.Offset(0, -2)
Debug.Print "Target "; Target
Debug.Print "rvalue.value "; rValue.Value
'This will loop through a different column, to find the value identified above, and return its cell address in the other column.
With PendRng
Set rFoundCell = .Cells(1, 1)
For lLoop = 1 To WorksheetFunction.CountIf(.Cells, rValue.Value)
Set rFoundCell = .Find(What:=rValue.Value, _
After:=rFoundCell, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
Debug.Print "rfoundcell " & rFoundCell
If Not rFoundCell Is Nothing Then
MsgBox "val: " & rValue.Value & " Matching Cell: " & rFoundCell.Address
'This will use the cell address identified above to move the active cell to that address.
'Have to convert the address to row/column to use in Cell.Select.
Cells(Range(rFoundCell.Address).Row, Range(rFoundCell.Address).Column).Select
Else
MsgBox (rValue.Value & " not found.")
GoTo end_search
End If
Next lLoop
End With
End If
End If
end_search:
End Sub
Received help w/ this code here:
Execute a subroutine when a user enters a trigger into a cell
I believe that your code is skipping the If statement that generates the error box if there is not a match.
This is due to For lLoop = 1 To WorksheetFunction.CountIf(.Cells, rValue.Value) exiting when there is no matches because it equates to For lLoop = 1 To 0
I moved all of your error message code into an If statement above the lLoop as follows:
If WorksheetFunction.CountIf(.Cells, rValue.Value) = 0 Then
MsgBox (rValue.Value & " not found.")
GoTo end_search
End If
My Friends,
I have two sheets (Sheet1 & Sheet2). in sheet2, Column B all the staff names,
and in the sheet1 there is a form to complete, in Cell C3 of it the name of staff is required to be written. what I want to do is "when I write the initial letters of the employee name, I want Excel to give me option names based on Sheet2, Column B. like when we write in Google anything, Google give options.
thanks in Advance for your help.
another idea is use VBA, I've updated the byundt's code.
It's not possible to show immediately the autofill, but you can type some characters and when you play enter the code check the list and if is one match, autofill the data, otherwise ask user if validate the missing name and add it to the list o delete the last value entered.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cel As Range, match1 As Range, match2 As Range, rg As Range, targ As Range
Set targ = Intersect(Target, Range("C:C")) 'Watch the cells in column C
Set sh = Worksheets("registry") 'the sheet2 where you have the list of names
Set rg = sh.Range("A2", "A" & sh.Range("A1").End(xlDown).Row)
If targ Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error GoTo errhandler
For Each cel In targ
If Not IsError(cel) Then
If cel <> "" And cel <> " " And Right(cel, 1) <> Chr(10) Then
Set match1 = Nothing
Set match1 = rg.Find(cel & "*", lookat:=xlWhole, MatchCase:=False)
If Not match1 Is Nothing Then
Set match2 = rg.FindNext(after:=match1)
If match2.Address = match1.Address Then
cel = match1
Else
cel.Activate
Application.SendKeys ("{F2}")
End If
Else 'No matches found. The value will be added of the end of range list
msg = "The value """ & Target & """ is not in list, " & vbCrLf & "do you whant to add this item??"
response = MsgBox(msg, 4, "Update list")
If response = 6 Then
sh.Range("A" & sh.Range("A1").End(xlDown).Row + 1) = Target
Else
Range(Target.Address) = ""
End If
End If
Else
If cel <> "" And Right(cel, 1) = Chr(10) Then cel = Left(cel, Len(cel) - 1)
End If
End If
Next cel
errhandler: Application.EnableEvents = True
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
I'm new to VBA Macro in Excel, and would just like to ask if there's any function for checking duplicate records in excel.
This line of code below removes duplicate referring to column A, but I don't want to actually remove it without user's confirmation, what I wanted to do is to ask for user's confirmation if he wants it to be removed or not, like a popup, and then this line would just execute, but I have no idea if there's a function for checking duplicates.
ActiveSheet.Range("$A$1:$D$38").RemoveDuplicates Columns:=1
Thanks in advance for your help.
Please try the following code. I've set script to make duplicate cell empty, but you can insert your own code.
Sub FindDuplicates()
Dim i As Long
Dim j As Long
Dim lDuplicates As Long
Dim rngCheck As Range
Dim rngCell As Range
Dim rngDuplicates() As Range
'(!!!!!) Set your range
Set rngCheck = ActiveSheet.Range("$A$1:$D$38")
'Number of duplicates found
lDuplicates = 0
'Checking each cell in range
For Each rngCell In rngCheck.Cells
Debug.Print rngCell.Address
'Checking only non empty cells
If Not IsEmpty(rngCell.Value) Then
'Resizing and clearing duplicate array
ReDim rngDuplicates(0 To 0)
'Setting counter to start
i = 0
'Starting search method
Set rngDuplicates(i) = rngCheck.Find(What:=rngCell.Value, After:=rngCell, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
'Check if we have at least one duplicate
If rngDuplicates(i).Address <> rngCell.Address Then
'Counting duplicates
lDuplicates = lDuplicates + 1
'If yes, continue filling array
Do While rngDuplicates(i).Address <> rngCell.Address
i = i + 1
ReDim Preserve rngDuplicates(0 To i)
Set rngDuplicates(i) = rngCheck.FindNext(rngDuplicates(i - 1))
Loop
'Ask what to do with each duplicate
'(except last value, which is our start cell)
For j = 0 To UBound(rngDuplicates, 1) - 1
Select Case MsgBox("Original cell: " & rngCell.Address _
& vbCrLf & "Duplicate cell: " & rngDuplicates(j).Address _
& vbCrLf & "Value: " & rngCell.Value _
& vbCrLf & "" _
& vbCrLf & "Remove duplicate?" _
, vbYesNoCancel Or vbExclamation Or vbDefaultButton1, "Duplicate found")
Case vbYes
'(!!!!!!!) insert here any actions you want to do with duplicate
'Currently it's set to empty cell
rngDuplicates(j).Value = ""
Case vbCancel
'If cancel pressed then exit sub
Exit Sub
End Select
Next j
End If
End If
Next rngCell
'Final message
Call MsgBox("Total number of duplicates: " & lDuplicates & ".", vbExclamation Or vbDefaultButton1, Application.Name)
End Sub
P.S. If you need to remove dulpicates only inside one column, you need to adjust rngCheck variable to that particular column.
P.P.S. In my opinion, it's easier to use conditional formatting.