PDA

View Full Version : [SOLVED] Delete Duplicate data on sheet2 and delete the row



parscon
09-19-2013, 11:09 AM
I have a VBA code that check the Column A on sheaet1 and check Column A on sheet2 and if found duplicate data will delete that row on sheet2

Now i have one problem and one request .

1- the problem is : when i have duplicate data on column A on sheet2 it will just delete the first one that founded and for example

Sheet1 Column A1 I have BOY and On Sheet2 Column A12 BOY and A34 BOY , when run my VBA code it will delete the BOY on A12 Sheet2 and will not delete the BOY on A34.

2- Request : Now i need to check all column in one row and if find duplicate data (that matched with data on column A on sheet1) on any column of that row on sheet2 delete them on sheet2.

For example : Sheet1 : A1 BOY Sheet2:B35 BOY it will delete that row.




Sub DelMatchedRows()

Dim LastRow As Long, i As Long, mRow As Long

With Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 1 To LastRow
On Error Resume Next
mRow = Application.Match(.Cells(i, 1), Worksheets("Sheet2").Columns(1), 0)
If mRow > 0 Then Worksheets("Sheet2").Rows(mRow).EntireRow.Delete
Next
End With

End Sub





Thank you very much.

ZVI
09-19-2013, 06:56 PM
May be this ;)


Sub DelMatchedRows1()

Dim a(), b()
Dim c As Long, r As Long
Dim k As String
Dim rng As Range, x As Range

' Freeze screen updating
Application.ScreenUpdating = False

' Trap errors
On Error GoTo exit_

1 ' Copy data of Sheet2 to array b() for speeding up the code
With Sheets(2).UsedRange
b() = .Value
Set rng = .EntireRow
End With

2 ' Main
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
' Copy column A of Sheet1 to array a() to speed code up
a() = Sheets(1).UsedRange.Columns("A").Value
' Build dictionary of Sheet1 Column A
For r = 1 To UBound(a)
k = Trim(a(r, 1))
If Len(k) Then .Item(k) = 0
Next
3 ' Collect in x the rows to be deleted
For r = 1 To UBound(b)
For c = 1 To UBound(b, 2)
k = Trim(b(r, c))
If Len(k) Then
If .Exists(k) Then
' Collect the row for deleting
If x Is Nothing Then
Set x = rng.Rows(r)
Else
Set x = Union(x, rng.Rows(r))
End If
Exit For
End If
End If
Next
Next
End With

4 ' Delete the collected rows
If Not x Is Nothing Then x.Delete

exit_:

' Inform about the trapped error
If Err Then MsgBox Err.Description, vbCritical, "Error #" & Err.Number & ", ErrLine #" & Erl

' Restore screen updating
Application.ScreenUpdating = True

End Sub

parscon
09-19-2013, 11:25 PM
Thank you very much .