Consulting

Results 1 to 2 of 2

Thread: Duplicate Finding between 2 sheets

  1. #1
    VBAX Regular
    Joined
    Jul 2004
    Posts
    13
    Location

    Duplicate Finding between 2 sheets

    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

  2. #2
    VBAX Regular
    Joined
    May 2004
    Location
    Springfield, MO
    Posts
    39
    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.
    [vba]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 [/vba]

Posting Permissions

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