PDA

View Full Version : [SOLVED] Duplicate Finding between 2 sheets



john
08-10-2004, 04:29 AM
Hi,
Hi,

In the attahed file there are 2 sheets, one is input and the other is output. In input sheet, the highlighted records(also having ROW NUM in coulmn A) are the reference for the non-highlighten records. Only the non-highlighted records have to match with the highlighted as follows:

1) Column B, C, D should match exactly between the rows (case-insensitive)
2) Column E and F can match any 8 continous characters between the rows (case-insensitive)... If this conditions are true, then I have to get the ROW NUM from the Highlighted and paste it in a new column(Result) against the Non-highlighted as shown in output sheet.

Could it possible to do by a VBA?

Thanks in Advance
John

byundt
08-14-2004, 01:28 PM
Try the following sub in a regular module sheet. It will insert a new column A in the active sheet, then find those rows that match (case insensitive) in original columns B,C & D and have at least eight characters matching in original columns E & F. When a match is found, the row number is copied to the new column A for the matching row.


Sub MatchRecords()
Dim rg As Range, rw As Range
Dim i As Long, j As Long, k As Long, lng As Long, nRows As Long
Dim boo As Boolean
Dim str As String
Application.ScreenUpdating = False
nRows = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
Columns(1).Insert
Cells(1, 1) = "Result"
Cells(1, 1).Font.Bold = True
Set rg = Range(Cells(1, 1), Cells(nRows, 7)) 'The range of cells to compare to current row
For i = 1 To nRows
If IsNumeric(Cells(i, 2)) And Cells(i, 2) <> "" Then
For Each rw In rg.Rows
j = rw.Row
If rw.Row <> i And LCase(Cells(i, 3)) = LCase(rw.Cells(3)) And Cells(i, 4) = rw.Cells(4) _
And Cells(i, 5) = rw.Cells(5) Then
For j = 6 To 7
boo = False
str = LCase(Cells(i, j))
lng = Len(str)
If lng > 8 Then
For k = 1 To lng - 7
If LCase(rw.Cells(j)) Like "*" & Mid(str, k, 8) & "*" Then
boo = True
Exit For
End If
Next k
Else
If LCase(rw.Cells(j)) Like "*" & str & "*" Then
boo = True
Exit For
End If
End If
If boo = False Then Exit For
Next j
If boo = True Then Cells(i, 2).Copy rw.Cells(1)
End If
Next rw
End If
Next i
Application.ScreenUpdating = True
End Sub