Requirement - compare two rows , if found duplicate row ,display popup of "duplicate rows" and wouldn't proceed to next cell.. this code is not working as it is comparing column.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastRow As Long, j As Long
If Not Intersect(Target, Columns("G:L")) Is Nothing Then
If Target.Value <> "" Then
lastRow = Cells(Rows.Count, Target.Column).End(xlUp).Row
For j = 1 To lastRow
If Cells(j, Target.Column).Value = Target.Value And j <> Target.Row Then
MsgBox "row having same value"
Target.Clear: Target.Select
Exit For
End If
Next j
End If
End If
End Sub
You don't have to loop. You can use the excel function CountIf
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.CountLarge > 1 Then Exit Sub
If Not Intersect(Target, Columns("G:L")) Is Nothing Then
If Target.Value <> "" Then
If Application.WorksheetFunction.CountIf(Columns(Target.Column), Target.Value) > 1 Then
MsgBox "Row Having Same Value"
Application.EnableEvents = False
Target.ClearContents: Target.Select
Application.EnableEvents = True
End If
End If
End If
End Sub
Related
I am currently trying to prevent users from entering duplicate entries between two columns (Column A and B). Values found in Column A should not be duplicated in Column B and my current code is not working
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet, EvalRange As Range
Set EvalRange = Range("AA:BB")
If Intersect(Target, EvalRange) Is Nothing Or Target.Cells.Count > 1 Then Exit Sub
If IsEmpty(Target) Then Exit Sub
If WorksheetFunction.CountIf(EvalRange, Target.Value) > 1 Then
MsgBox Target.Value & " already exists on this sheet."
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
End If
End Sub
Here's one approach using Match:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim v, col As Range
If Target.Cells.Count > 1 Then Exit Sub 'run some checks...
If Intersect(Target, Me.Range("A:B")) Is Nothing Then Exit Sub
v = Target.Value
If Len(v) = 0 Then Exit Sub
Set col = Me.Columns(IIf(Target.Column = 1, 2, 1)) 'set column to check
If Not IsError(Application.Match(v, col, 0)) Then
MsgBox Target.Value & " already exists in column " & Left(col(1).Address(False, False), 1)
Application.EnableEvents = False
Application.Undo
Application.EnableEvents = True
End If
End Sub
I need help with Excel VBA code.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 And Target.Cells.Count = 1 Then
If LCase(Target.Value) = "-1" Then
With Target.EntireRow.ClearContents
End With
End If
End If
If Target.Column = 3 And Target.Cells.Count = 1 Then
If LCase(Target.Value) = "1000" Then
With Target.EntireRow
.Copy Sheets("Week Schedule").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Delete
End With
End If
End If
End Sub
If the third column we enter -1 it will clear the row. If we enter 1000 it will be copied to another sheet and deleted from the current sheet.
The above code is working fine. Instead of clearing row data, I want to delete that row.
So added
Line 4 With Target.EntireRow.ClearContents to With Target.EntireRow.Delete
But it shows an error.
It would help to know what error you get. Assuming the error is caused because the Week Schedule sheet does not exist, you can add a check for that. After that, your code works fine:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 And Target.Cells.Count = 1 Then
If LCase(Target.Value) = "-1" Then
With Target.EntireRow.ClearContents
End With
End If
End If
If Target.Column = 3 And Target.Cells.Count = 1 Then
If LCase(Target.Value) = "1000" Then
With Target.EntireRow
SheetExistsOrCreate ("Week Schedule")
.Copy Sheets("Week Schedule").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Delete
End With
End If
End If
End Sub
Function SheetExistsOrCreate(name As Variant)
For i = 1 To Worksheets.Count
If Worksheets(i).name = "MySheet" Then
exists = True
End If
Next i
If Not exists Then
Worksheets.Add.name = name
End If
End Function
Please, try the next adapted code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 And Target.Cells.Count = 1 Then
Application.EnableEvents = False
If LCase(Target.Value) = -1 Then
Target.EntireRow.Delete
ElseIf Target.Value = 1000 Then
With Target.EntireRow
.Copy Sheets("Week Schedule").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Delete
End With
End If
Application.EnableEvents = True
End If
End Sub
The above code assumes that the Target value means a number, not a string looking as a number. If a string, you can place them between double quotes, as in your initial code.
Of course, a sheet named "Week Schedule" must exist in the active workbook and must not be protected.
I have a code that fills the date in column 3 when the there is a change in values of a cell Range("E:J"). It works fine, but I would also like to display the values of column 4 (col 4 is hidden) in column 11, only when all the cells in the Range(E:J) are filled.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Intersect(Target, Range("E:J")) Is Nothing Then Exit Sub
Application.EnableEvents = False
If Target.Value <> vbNullString Then
Target.Offset(0, 3 - Target.Column).Value = Date
Target.Offset(0, 3 - Target.Column).NumberFormat = "dd/mmm/yyyy"
Else
Target.Offset(0, 3 - Target.Column).ClearContents
End If
Application.EnableEvents = True
End Sub
Any help on this would be greatly appreciated.
Thanks.
Consider:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim tc As Long, r As Range, tr As Long
Dim wf As WorksheetFunction
Set wf = Application.WorksheetFunction
If Target.Count > 1 Then Exit Sub
tc = Target.Column
tr = Target.Row
If Intersect(Target, Range("E:J")) Is Nothing Then Exit Sub
Set r = Range(Cells(tr, "E"), Cells(tr, "J"))
Application.EnableEvents = False
If Target.Value <> vbNullString Then
Target.Offset(0, 3 - tc).Value = Date
Target.Offset(0, 3 - tc).NumberFormat = "dd/mmm/yyyy"
Else
Target.Offset(0, 3 - tc).ClearContents
End If
If wf.CountA(r) = 6 Then
Cells(tr, 11).Value = Cells(tr, 4).Value
End If
Application.EnableEvents = True
End Sub
I'd like to preface by saying I am a novice to VBA, so hopefully this is an easy fix.
I am trying to get the following VBA code to work for multiple cells with formulas. The effect is that there is a ghost value in the cell a user can overwrite then see again if they delete their value. I can get one cell to work how I want it to, but the second (and third and fourth etc.) do not work. How can I repeat this same line of code so that the effect repeats itself in multiple cells with different formulas?
Working:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
With Target
If .Address(False, False) = "F7" Then
If IsEmpty(.Value) Then
Application.EnableEvents = False
.Formula = "=IFERROR(INDEX(DATABASE!$D$2:$AG$3222,MATCH('Pricing Grid'!$B$11,DATABASE!$E$2:$E$3222,0),10),0)"
Application.EnableEvents = True
End If
End If
End With
End Sub
My attempt (Top working, bottom not):
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
With Target
If .Address(False, False) = "F7" Then
If IsEmpty(.Value) Then
Application.EnableEvents = False
.Formula = "=IFERROR(INDEX(DATABASE!$D$2:$AG$3222,MATCH('Pricing Grid'!$B$11,DATABASE!$E$2:$E$3222,0),10),0)"
Application.EnableEvents = True
End If
End If
End With
End Sub
Private Sub Worksheet_Change1(ByVal Target As Excel.Range)
With Target
If .Address(False, False) = "F8" Then
If IsEmpty(.Value) Then
Application.EnableEvents = False
.Formula = "=IFERROR(INDEX(DATABASE!$D$2:$AG$3222,MATCH('Pricing Grid'!$B$11,DATABASE!$E$2:$E$3222,0),9),0)"
Application.EnableEvents = True
End If
End If
End With
End Sub
Try this...
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i&, j&, v, t
v = Target.Value2
If Not IsArray(v) Then t = v: ReDim v(1 To 1, 1 To 1): v(1, 1) = t
Application.EnableEvents = False
For i = 1 To UBound(v)
For j = 1 To UBound(v, 2)
If Len(v(i, j)) = 0 Then
With Target(i, j)
Select Case .Address(0, 0)
Case "A1": .Formula = "=""Excel"""
Case "A2": .Formula = "=""Hero"""
End Select
End With
End If
Next
Next
Application.EnableEvents = True
End Sub
Use your formulas and ranges instead of mine, of course.
Update
The above works well, but this is faster/better...
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i&, v
DoEvents
ReDim v(1 To 3, 1 To 2)
v(1, 1) = "A1": v(1, 2) = "=""This"""
v(2, 1) = "A2": v(2, 2) = "=""Works"""
v(3, 1) = "A2": v(3, 2) = "=""Great!"""
Application.EnableEvents = False
For i = 1 To UBound(v)
With Range(v(i, 1))
If Not Intersect(Target, .Cells) Is Nothing Then
If Len(.Value2) = 0 Then
.Formula = v(i, 2)
End If
End If
End With
Next
Application.EnableEvents = True
End Sub
Both of the above methods work for single-cell deletes AND also for clearing and deleting large ranges, including whole columns and whole rows and the second method is particularly quick in all these scenarios.
You can do something like this:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
'only handle single cells
If Target.Cells.CountLarge > 1 Then Exit Sub
If IsError(Target.Value) Then Exit Sub '<< edit: added
'only handle empty cells
If Len(Target.Value) > 0 Or Len(Target.Formula) > 0 Then Exit Sub
On Error Goto haveError
Application.EnableEvents = False
Select Case Target.Address(False, False)
Case "F7": Target.Formula = "=IFERROR(INDEX(DATABASE!$D$2:$AG$3222,MATCH('Pricing Grid'!$B$11,DATABASE!$E$2:$E$3222,0),10),0)"
Case "F8": Target.Formula = "=IFERROR(INDEX(DATABASE!$D$2:$AG$3222,MATCH('Pricing Grid'!$B$11,DATABASE!$E$2:$E$3222,0),9),0)"
End Select
haveError:
'ensure events are re-enabled
Application.EnableEvents = True
End Sub
In my sheet columns B:C allow dates. I'm trying to create a check to see whether a date entered in C is more recent than B, if so fine, else alert the user and clear contents.
My code returns a run-time error 91 in the application.intersect line:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Dates As Range
Set Dates = Range("C4:C12")
If Target.Cells.Count > 1 Or IsEmpty(Target) Then
Exit Sub
End If
If Not Application.Intersect(Dates, Range(Target.Address)).Value > ActiveCell.Offset(0, -1).Value Then
GoTo DatesMissMatch
Else
Exit Sub
End If
DatesMissMatch:
Target.ClearContents
ActiveCell.Value = "A2"
MsgBox "Please re-check dates"
End Sub
I changed your method, but this seems to be working.
I also noticed that you were writing A2 to ActiveCell instead of Target. Did you want the cell in column C to update if invalid data is entered or did you intend for it to be whichever cell you move to that gets changed?
At any rate, here's a way I came up with it
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Or IsEmpty(Target) Then
Exit Sub
End If
If Target.Column = 3 Then 'Check to see if column C was modified
If Target.Value < Target.Offset(0, -1).Value Then
Target.ClearContents
Target.Value = "A2"
MsgBox "Please re-check dates"
End If
End If
End Sub
If you want to stick with the way you are currently doing it, then I think you need to check that the Intersection is not empty as another answer concludes.
I believe you just have to check the intersect than do the compare.
Sub Worksheet_Change(ByVal Target As Range)
Dim Dates As Range
Set Dates = Range("C4:C12")
If Target.Cells.Count > 1 Or IsEmpty(Target) Then
Exit Sub
End If
If Not Application.Intersect(Dates, Range(Target.Address)) Is Nothing Then
If Target.Value < Target.Offset(0, -1).Value Then
GoTo DatesMissMatch
Else
Exit Sub
End If
End If
DatesMissMatch:
Target.ClearContents
ActiveCell.Value = "A2"
MsgBox "Please re-check dates"
End Sub
You can just loop the rows and compare the dates.
Dim ws As Excel.Worksheet
Set ws = Application.ActiveSheet
Dim lRow As Long
lRow = 4
Do While lRow <= ws.UsedRange.Rows.count
If ws.Range("C" & lRow).Value > ws.Range("B" & lRow).Value then
GoTo DatesMissMatch
End if
lRow = lRow + 1
Loop