Duplicate Finding between 2 sheets

[john]

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]

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