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