Results 1 to 2 of 2

Thread: Duplicate Finding between 2 sheets

  1. #1
    VBAX Regular
    Jul 2004

    Duplicate Finding between 2 sheets


    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

  2. #2
    VBAX Regular
    May 2004
    Springfield, MO
    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
    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
                            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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts