Hi there,
Here's one possible VBA solution (one of many I'd imagine):
Sub Macro2()
Dim lngLastRow As Long
Dim rngCell As Range, _
rngMyData As Range, _
rngMyDups As Range
Dim blnDupsExist As Boolean
Dim strPasteSheetName As String
lngLastRow = Sheets("Sheet1").Cells(Rows.Count, "H").End(xlUp).Row
Set rngMyData = Sheets("Sheet1").Range("H2:H" & lngLastRow)
blnDupsExist = False
Application.ScreenUpdating = False
For Each rngCell In rngMyData
If Application.WorksheetFunction.CountIf(rngMyData, rngCell.Value) > 1 Then
blnDupsExist = True
If rngMyDups Is Nothing Then
Set rngMyDups = rngCell.EntireRow
Else
Set rngMyDups = Union(rngMyDups, rngCell.EntireRow)
End If
End If
Next rngCell
If blnDupsExist = False Then
MsgBox "There are no duplicates in the range " & rngMyData.Address & ".", vbExclamation, "My Duplicates Editor"
Else
Worksheets.Add after:=Worksheets(Worksheets.Count)
With rngMyDups
.Copy Sheets(ActiveSheet.Name).Range("A2")
.EntireRow.Delete xlShiftUp
End With
MsgBox "The duplicates have now been moved to the """ & ActiveSheet.Name & """ tab.", vbInformation, "My Duplicates Editor"
End If
Application.ScreenUpdating = True
End Sub
Regards,
Robert