prevent duplicates based on two non-contiguous columns 1

[AzizKamal]

I have a Sheet named Allowances with the following columns:

A: Emp #
B: Employee Name
C: Month
D: Month Code
E: Allowance
F: Allowance Code
G: Overtime Rate
H: Hour
I: Amount

Employee Name and Allowance have Data Validation Combo boxes with Sources as EmpName and Allowance respectively.

EmpName refers to

=OFFSET(LookupValues!$A$2,0,0,COUNTA(LookupValues!$A:$A)-1,1)

Allowance refers to

=OFFSET(LookupValues!$H$2,0,0,COUNTA(LookupValues!$H:$H)-1,1)

What I need to achieve is prevent duplicate entry for Employee Name (Column B) and Allowance (Colunmn E) Pair. For example:

Employee Name = N1, Allowance=Overtime Payment is OK
Employee Name = N1, Allowance=Leave Encashment is OK

But
Employee Name=N1, Allowance=Overtime Payment is OK
Employee Name=N1, Allowance=Overtime Payment (Not Allowed,Duplicate)

The following code works OK for a single column:

Private Sub Worksheet_Change(ByVal Target As Range)

Select Case Target.Column

    Case 2
        MyRange = "$B$2:" & Target.Offset(-1, 0).Address
        With Range(MyRange)
            If Target.Offset(-1, 0).Address <> "$B$1" And Target.Value <> "" Then
                Set c = .Find(Target.Value, LookIn:=xlValues)
                If Not c Is Nothing Then
                    Application.EnableEvents = False
                    MsgBox "Duplicate values not allowed..."
                    Target.ClearContents
                    Application.EnableEvents = True
                    Exit Sub
                End If
            End If
        End With
End Select

But I need to accomplish this for two columns:

I have the search string for Range.Find method in this:

target.Offset(0,-3) & target.Value

Excel help provides one code for multiple columns in Range.Find method:

For Each c In [A1:C5] If c.Font.Name Like "Cour*" Then c.Font.Name = "Times New Roman" End If Next

But I am not sure it will work in my scenario as I need to check the actual values in two columns and also, these two columns are not adjacent to each other.

 

[Bong]

I prefer to use r/c notation rather than addresses; I hope that won't be a problem.

From the look of your code, it appears that this macro is triggered any time any cell is altered on the spreadsheet. Is that truly what you want?

Anyway, you come in with Target which is where the change occurred. What I think you want to do is check that, in the row of Target, the values of columns 2 and 5 are not both equal to the columns 2 and 5 of any preceding row. To do that I would march down those rows and check:

rwT=Target.row
for r=1 to rwT-1
   if rwT.cells(2)=r.cells(2) and rwT.cells(5)=r.cells(5) then
     Application.EnableEvents = False
     MsgBox "Duplicate values not allowed..."
     Target.ClearContents
     Application.EnableEvents = True
     Exit Sub
   end if
next

_________________
Bob Rashkin

 

[AzizKamal]

Thanks a lot Bob.

I tried the following code:

Private Sub Worksheet_Change(ByVal Target As Range)
Select Case Target.Column
Case 5 'Column 5 is for Allowance Entry
        rwt = Target.Row
        For r = 1 To rwt - 1
            If rwt.Cells(2) = r.Cells(2) And rwt.Cells(5) = r.Cells(5) Then
                Application.EnableEvents = False
                MsgBox "Duplicate values not allowed..."
                Target.ClearContents
                Application.EnableEvents = True
                Exit Sub
            End If
        Next
End Select
End Sub

it generated the following error:
Run-time error '424':
Object required

Then I modified row,column syntax to execute the following code:

Private Sub Worksheet_Change(ByVal Target As Range)
Select Case Target.Column
Case 5 'Column 5 is for Allowance Entry
        rwt = Target.Row
        For r = 1 To rwt - 1
            If Cells(rwt, 2) = Cells(r, 2) And Cells(rwt, 5) = Cells(r, 5) Then
                Application.EnableEvents = False
                MsgBox "Duplicate values not allowed..."
                Target.ClearContents
                Application.EnableEvents = True
                Exit Sub
            End If
        Next
End Select
End Sub

and it worked perfectly.

Thanks once again and have a star.