Hi All,
The below macro will delete the duplicate entry in an excel sheet and it will only retain the latest or last entry made
Sub deleteDuplicate(Book2 As String)
Dim cRow As Integer
Dim cRow2 As Integer
Dim MNOT As Integer
Dim cCol As Integer
Dim foundDuplicate As Boolean
For MNOT = 1 To 500
cRow = 2
Do While IsEmpty(Worksheets(Book2).Cells(cRow, 1)) = False
cRow2 = cRow + 1
Do While IsEmpty(Worksheets(Book2).Cells(cRow2, 1)) = False
foundDuplicate = True
For cCol = 1 To 4
If Worksheets(Book2).Cells(cRow, cCol).Value <> Worksheets(Book2).Cells(cRow2, cCol).Value Then
foundDuplicate = False
Exit For
End If
Next
If foundDuplicate = True Then
Worksheets(Book2).Rows(cRow).Delete xlShiftUp
Else
cRow2 = cRow2 + 1
End If
Loop
cRow = cRow + 1
Loop
Next
End Sub
Sub test()
deleteDuplicate "Sheet1"
End Sub
The below macro will delete the duplicate entry in an excel sheet and it will only retain the latest or last entry made
Sub deleteDuplicate(Book2 As String)
Dim cRow As Integer
Dim cRow2 As Integer
Dim MNOT As Integer
Dim cCol As Integer
Dim foundDuplicate As Boolean
For MNOT = 1 To 500
cRow = 2
Do While IsEmpty(Worksheets(Book2).Cells(cRow, 1)) = False
cRow2 = cRow + 1
Do While IsEmpty(Worksheets(Book2).Cells(cRow2, 1)) = False
foundDuplicate = True
For cCol = 1 To 4
If Worksheets(Book2).Cells(cRow, cCol).Value <> Worksheets(Book2).Cells(cRow2, cCol).Value Then
foundDuplicate = False
Exit For
End If
Next
If foundDuplicate = True Then
Worksheets(Book2).Rows(cRow).Delete xlShiftUp
Else
cRow2 = cRow2 + 1
End If
Loop
cRow = cRow + 1
Loop
Next
End Sub
Sub test()
deleteDuplicate "Sheet1"
End Sub
No comments:
Post a Comment