Match "2" values before marked as Duplicate

[wrightyrx7]

Hi All,

The code which I currently use, it finds duplicates in column A and when one is found it inputs the word "Duplicate" on the row.

Is it possible to change it for it to look at columns A and M. If it matches column A and M on another worksheet then it will input the word DUPLICATE?


Sub FindMultipleStaff()
Dim wksht As Long, LastRow As Long, lastrow1 As Long
Dim Rng As Range, icell As Range, c As Range
Dim startaddress As Variant
Dim cCnt As Integer

lastrow1 = Sheets(1).Range("C" & Rows.Count).End(xlUp).Row

Application.ScreenUpdating = False

For wksht = 2 To Worksheets.Count
For Each icell In Sheets(1).Range("A2:A" & lastrow1)
LastRow = Sheets(wksht).Range("A" & Rows.Count).End(xlUp).Row
Set Rng = Sheets(wksht).Range("A2:A" & LastRow)
With Rng
Set c = .Find(What:=icell.Value, LookAt:=xlWhole, LookIn:=xlValues, SearchDirection:=xlNext)
If Not c Is Nothing Then
Application.ScreenUpdating = False
cCnt = icell.End(xlToRight).Column + 1
With Cells(icell.Row, cCnt)
.Font.Color = vbRed
.Value = "Duplicate"
End With
startaddress = c.Address
Do
c.Font.Color = vbBlue
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> startaddress
Application.ScreenUpdating = True
End If
End With
Next icell
Next wksht

On Error GoTo Finish

Finish:
Err.Clear
Exit Sub
End Sub

Thanks in advance.

Chris

[Bob Phillips]

Match M on the same row as the match on A or any row?

[wrightyrx7]

Hello, Thank you for the reply.

On the same row please.

On a row of data i have a ID number in column A and date joined in column M. Sometimes a person could join again but will have the same ID number but the date joined would of changed in column M. So in some cases the ID number will be the same but date joined is different therefore this will NOT be a duplicate.

If you need anymore information please let me know.

Thanks again
Chris

[Bob Phillips]

Sub FindMultipleStaff()
Dim wksht As Long, LastRow As Long, lastrow1 As Long
Dim Rng As Range, icell As Range, c As Range
Dim startaddress As Variant
Dim cCnt As Integer

lastrow1 = Sheets(1).Range("C" & Rows.Count).End(xlUp).Row

Application.ScreenUpdating = False

For wksht = 2 To Worksheets.Count
For Each icell In Sheets(1).Range("A2:A" & lastrow1)
LastRow = Sheets(wksht).Range("A" & Rows.Count).End(xlUp).Row
Set Rng = Sheets(wksht).Range("A2:A" & LastRow)
With Rng
Set c = .Find(What:=icell.Value, LookAt:=xlWhole, LookIn:=xlValues, SearchDirection:=xlNext)
If Worksheets(1).Cells(icell.Row, "M").Value = Worksheets(wksht).Cells(c.Row, "M").Value Then
If Not c Is Nothing Then
Application.ScreenUpdating = False
cCnt = icell.End(xlToRight).Column + 1
With Cells(icell.Row, cCnt)
.Font.Color = vbRed
.Value = "Duplicate"
End With
startaddress = c.Address
Do
c.Font.Color = vbBlue
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> startaddress
Application.ScreenUpdating = True
End If
End If
End With
Next icell
Next wksht

On Error GoTo Finish

Finish:
Err.Clear
Exit Sub
End Sub

[wrightyrx7]

Thank you very much for this. I have tested it and have run into a problem when i come to my first NON Duplicate i got:-


"Run-time error '91': Object variable or With block variable not set"


Do you know why this is?

Thanks
Chris

[Bob Phillips]

Post some data.

[wrightyrx7]

Hi xld,

I have tried this with test data nothing special.

1 - 10 column A on sheet1 and sheet2
random dates in column M on sheet1 and sheet2

Making sure that a few of them are duplicates.

Regards
Chris

[GTO]

Post some data.

Greetings Chris,

Wouldn't it seem more helpful to attach a small workbook with some data that causes the code to fail? Elsewise, we are guessing at what you have; not to mention that any/each 'helper' must create what you could attach just once.

Mark

[wrightyrx7]

Hello,

I have attached some data, rows 1 - 10 should be fine but 11 - 19 are duplicates.

Thank you for your help with this.

Regards
Chris

[wrightyrx7]

Anyone? :( need this to finish my work today.

[Bob Phillips]

Your code is setting lastrow based on column C in Sheet1, you should change it to column A.

[wrightyrx7]

Your code is setting lastrow based on column C in Sheet1, you should change it to column A.

I noticed this and changed it but this wouldnt change the lastrow anyway because every row with data in column A has data in all the other used columns.

Even when i changed it i still got the error.

Regards
Chris

[Bob Phillips]

Error? You didn't mention an error, you said it didn't show duplicates.

[wrightyrx7]

I did in post #5

I put it in quotes? Is it not showing up?

CHris

[wrightyrx7]

So so so sorry xld, your code did work perfect i must of inserted something by accident. when i cleared module and input your code again it worked... sorry for messing about.

Many many thanks for your help!!

Chris

[wrightyrx7]

Spoke to soon :(

When the data gets to a value in column A (sheet1) that doesnt exist on sheet 2 it gives me the error mentioned earlier.

I have put the attachment of the data bring this error.

Regards
Chris

[Bob Phillips]

You just need to switch the test fod c is nothing before doing anything else




Sub FindMultipleStaff()
Dim wksht As Long, LastRow As Long, lastrow1 As Long
Dim Rng As Range, icell As Range, c As Range
Dim startaddress As Variant
Dim cCnt As Integer

lastrow1 = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row

Application.ScreenUpdating = False

For wksht = 2 To Worksheets.Count
For Each icell In Sheets(1).Range("A2:A" & lastrow1)
LastRow = Sheets(wksht).Range("A" & Rows.Count).End(xlUp).Row
Set Rng = Sheets(wksht).Range("A2:A" & LastRow)
With Rng
Set c = .Find(What:=icell.Value, LookAt:=xlWhole, LookIn:=xlValues, SearchDirection:=xlNext)
If Not c Is Nothing Then
If Worksheets(1).Cells(icell.Row, "M").Value = Worksheets(wksht).Cells(c.Row, "M").Value Then
Application.ScreenUpdating = False
cCnt = icell.End(xlToRight).Column + 1
With Cells(icell.Row, cCnt)
.Font.Color = vbRed
.Value = "Duplicate"
End With
startaddress = c.Address
Do
c.Font.Color = vbBlue
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> startaddress
Application.ScreenUpdating = True
End If
End If
End With
Next icell
Next wksht

On Error GoTo Finish

Finish:
Err.Clear
Exit Sub
End Sub

[wrightyrx7]

Works Great!

Thank you