lundi 14 décembre 2015

where to write the check for duplication values and delete it in my VBA code

i have a vba code that copy a table that contain 2 columns "name" and "contact" from the first sheet to the second sheet and it work perfect but what i want also is to check for duplicated values by checking if the column A and column B exist more than one time with the same values in this case delete one of them.

also i need to check if name do not have a contact number do not copy it.

can anyone help me to solve this problem ?

this is my code

Private Sub scanandCopyContactName_Click()

Dim row_number As Long, count_of_str As Long
    Dim rToSearch  As Range, rFound As Range, rng As Range
    Dim os As Long
    Dim strSearchTerm As String
    Dim FirstAddr As String
    Dim ws As Worksheet, rDest As Range

    Dim cl As Range, ar As Range

    ' Set up search parameteres
    strSearchTerm = "name"
    os = 1

    ' Set search range
    With Sheets("Sheet1")
        Set rToSearch = .Range(.Cells(5, 8), .Cells(.Rows.Count, 8).End(xlUp))
    End With

    ' Find first occurance
    Set rng = rToSearch.Find( _
      What:=strSearchTerm, _
      After:=rToSearch.Cells(rToSearch.Cells.Count), _
      LookIn:=xlValues, _
      LookAt:=xlPart, _
      SearchOrder:=xlByRows, _
      SearchDirection:=xlNext, _
      MatchCase:=False, _
      SearchFormat:=False)

    If Not rng Is Nothing Then
        FirstAddr = rng.Address
        ' Find all occurances
        Do
            count_of_str = count_of_str + 1
            If rFound Is Nothing Then
                Set rFound = rng.Offset(0, 1)
            Else
                Set rFound = Union(rFound, rng.Offset(0, 1))
            End If
            Set rng = rToSearch.FindNext(rng)
        Loop Until rng.Address = FirstAddr
    End If

    MsgBox "the str occured: " & count_of_str & " times."
    ' rFound now refers to all found cells

    ' Copy to somewhere
    Set ws = Worksheets("sheet2")     '<~~Update as required
    Set rDest = ws.Range("a2")    '<~~Update as required
    If Not rFound Is Nothing Then
        rFound.Copy rDest
    End If

    ' optional, process found cells
    ' eg
    If Not rFound Is Nothing Then
        For Each ar In rFound.Areas
        For Each cl In ar.Cells
            Debug.Print cl.Address
        Next cl, ar
    End If

End Sub

Aucun commentaire:

Enregistrer un commentaire