Excel Moving duplicate values to new sheet - vba

Question

I have compiled this code from bit and pieces I have found - I am by no means an expert - more of an eager student - This code works for me but now I need to keep the first occurrence of the duplicate row to stay on the original worksheet and move only the subsequent occurrence(s) to the newly created sheet.
I am willing to redo all the code if needed but would prefer to modify the existing vba for the sake of time
Sub moveduplicates
'***************************************************************
'** This proc expects you to select all the cells in a single **
'** column that you want to check for duplicates in. If dup- **
'** licates are found, the entire row will be copied to the **
'** predetermined sheet. **
'***************************************************************
Set Rng = ActiveCell
'Sticky_Selection()
Dim s As Range
Set s = Selection
Cells.EntireColumn.Hidden = False
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Duplicate Values"
Sheets("Data").Select
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Sheets("Duplicate Values").Select
Range("A1").Select
ActiveSheet.Paste
s.Parent.Activate
s.Select 'NOT Activate - possibly more than one cell!
Dim ShO As Worksheet
Dim Rng1 As Range
Dim pRow As Integer
Dim c As Range, cTmp As Range
Dim found
Dim Addresses() As String
Dim a() As String
Dim p2 As Integer
Dim tfFlag As Boolean, sTmp As Variant
Set ShO = Worksheets("Duplicate Values") 'You can change this to whatever worksheet name you want the duplicates in Set Rng1 = Application.InputBox("Select a range", "Obtain Range Object", Type:=8)
MsgBox "The cells selected were " & Rng.Address 'Rng1 is all the currently selected cells
pRow = 2 'This is the first row in our output sheet that will be used to record duplicates
ReDim a(0) 'Initialize our array that holds found values
For Each c In Rng1.Cells 'Cycle through each cell in our selected range
ReDim Addresses(0) 'This array holds the cell address for our duplicates.
'We will reset the array each time we move to the next cell
Now check the array of already found duplicates.
If the current value is already there skip to next value
tfFlag = False
For Each sTmp In a
If CStr(c.Value) = sTmp Or CStr(c.Value) = "xXDeleteXx" Then 'We've already done this value, move on
tfFlag = True
Exit For
End If
Next
If Not tfFlag Then 'Remember the flag is true when we have already located the
'duplicates for this value, so skip to next value
With Rng1
Set found = .Find(c.Value, LookIn:=xlValues) 'Search entire selected range for value
If Not found Is Nothing Then 'Found it
Addresses(0) = found.Address 'Record the address we found it
Do 'Now keep finding occurances of it
Set found = .FindNext(found)
If found.Address <> Addresses(0) Then
ReDim Preserve Addresses(UBound(Addresses) + 1)
Addresses(UBound(Addresses)) = found.Address
End If
Loop While Not found Is Nothing And found.Address <> Addresses(0) 'Until we get back to the original address
If UBound(Addresses) > 0 Then 'We Found Duplicates
a(UBound(a)) = c.Value 'Record the value we found a duplicate for in an array
'ReDim Preserve a(UBound(a) + 1) 'add an empty spot to the array for next value
'ShO.Range("A" & pRow).Value = "Duplicate Rows for Value " & c.Value & _
" in Column " & c.Column & " on original sheet" 'Add a label row
'pRow = pRow + 1 'Increment to the next row
For p2 = UBound(Addresses) To 0 Step -1 'Cycle through the duplicate addresses
Set cTmp = Rng1.Worksheet.Range(Addresses(p2)) 'we just want to easily get the correct row to copy
Rng1.Worksheet.Rows(cTmp.Row).Copy ShO.Rows(pRow) 'Copy form orig to duplicates sheet
cTmp.Value = "xXDeleteXx" 'Mark for Delete the original row
pRow = pRow + 1 'Increment row counter
Next p2
'Row = pRow + 1 'This increment will give us a blank row between sets of duplicates
End If
End If
End With
End If
Next
'Now go delete all the marked rows
Do
tfFlag = False
For Each c In Rng1
If c.Value = "xXDeleteXx" Then
Rng1.Worksheet.Rows(c.Row).Delete (xlShiftUp)
tfFlag = True
End If
Next
Loop Until tfFlag = False
'AutoFit Every Worksheet Column in a Workbook
For Each sht In ThisWorkbook.Worksheets
sht.Cells.EntireColumn.AutoFit
Next sht
Application.Goto Rng
End
End Sub
Thank you very much for your time and consideration

Answer 1

You can use a scripting Dictionary object to keep track of duplicates:
Sub RemoveDups()
Dim c As Range, dict, rngDel As Range, rw As Long
Dim wb As Workbook
Dim shtDups As Worksheet
Dim rng1 As Range
Set rng1 = Selection 'assuming you've selected a single column of values
' from which you want to remove dups
Set wb = ActiveWorkbook
Set shtDups = wb.Worksheets.Add( _
after:=wb.Worksheets(wb.Worksheets.Count))
shtDups.Name = "Duplicate Values"
With rng1.Parent
.Range(.Range("A2"), .Range("A2").End(xlToRight)).Copy _
shtDups.Range("A1")
End With
rw = 2
Set dict = CreateObject("scripting.dictionary")
For Each c In rng1.Cells
'already seen this value?
If dict.exists(c.Value) Then
c.EntireRow.Copy shtDups.Cells(rw, 1)
rw = rw + 1
'add row to "delete" range
If rngDel Is Nothing Then
Set rngDel = c
Else
Set rngDel = Application.Union(c, rngDel)
End If
Else
'first time for this value - add to dictionary
dict.Add c.Value, 1
End If
Next c
'delete all duplicate rows (if found)
If Not rngDel Is Nothing Then
rngDel.EntireRow.Delete
End If
End Sub

Answer 2

Another enthusiastic amateur here!
Not really answering your question, but here is a little function I use for removing duplicate rows:
Sub RemoveDupes(TempWB As Workbook, TargetSheet As String, ConcatCols As String, DeleteTF As Boolean)
Dim Counter As Integer
Dim Formula As String
Dim RowCount As Integer
Dim StartingCol As String
Dim CurrentRow As Integer
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Remove duplicate rows on a worksheet '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Prerequisites:
' - Data needs to start # A1
' - Data has headings in row 1
' determine number of rows to be processed
RowCount = TempWB.Sheets(TargetSheet).Cells(TempWB.Sheets(TargetSheet).Rows.Count, "A").End(xlUp).Row
' insert a column to hold the calculate unique key
TempWB.Sheets(TargetSheet).Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
' add a heading
TempWB.Sheets(TargetSheet).Cells(1, 1).Value = "Duplication Check"
' insert the unique key formula
For CurrentRow = 2 To RowCount
' start the formula string
Formula = "="
' construct the formula
For Counter = 1 To Len(ConcatCols)
' if we are on the last element, dont add another '&'
If Counter = Len(ConcatCols) Then
Formula = Formula & AddLetter(Mid(ConcatCols, Counter, 1)) & CurrentRow
Else
Formula = Formula & AddLetter(Mid(ConcatCols, Counter, 1)) & CurrentRow & "&"
End If
' Debug.Print Mid(ConcatCols, Counter, 1)'Next
' next element!
Next
' insert the newly constructed formula
TempWB.Sheets(TargetSheet).Cells(CurrentRow, "A").Formula = Formula
' next row
Next
' unfortunately we need to use explicit selection here *sigh*
TempWB.Sheets(TargetSheet).Activate
' to select the range we are going to test
TempWB.Sheets(TargetSheet).Range("A2:A" & TempWB.Sheets(TargetSheet).Cells(Rows.Count, "A").End(xlUp).Row).Select
' clock down the list flagging each dupe by changing the text color
Dim d As Object, e
Set d = CreateObject("scripting.dictionary")
For Each e In Intersect(Columns(ActiveCell.Column), ActiveSheet.UsedRange)
If e.Value <> vbNullString Then
If Not d.exists(e.Value) Then d(e.Value) = 1 Else _
e.Font.ColorIndex = 4
End If
Next
' if the delete flag is set...
If DeleteTF Then
' then go down the list deleting rows...
For CurrentRow = RowCount To 2 Step -1
' if the row has been highlighted, its time to go...
If TempWB.Sheets(TargetSheet).Cells(CurrentRow, "A").Font.ColorIndex = 4 Then
TempWB.Sheets(TargetSheet).Cells(CurrentRow, "A").EntireRow.Delete
End If
Next
' If we are deleting rows, remove the column just like we were never here
TempWB.Sheets(TargetSheet).Cells(1, "A").EntireColumn.Delete
End If
End Sub
Function AddLetter(Letter As String)
' gives you the next letter
AddLetter = Split(Cells(, Range(Letter & 1).Column + 1).Address, "$")(1)
End Function
When I get a sec I will have a go adapting this to your requirements...

Answer 3

This will search a specified column for duplicates, copying subsequent duplicates entries to Sheet2 and then remove them from Sheet1.
I've used the Scripting Dictionary too but you will need to add a reference to "Microsoft Scripting Runtime" for the code to work as-is. (Adding the reference will help if you want to learn about dictionaries since it adds the Dictionary to Intellitype code completion stuff)
Sub Main()
Dim SearchColumn As Integer: SearchColumn = 2 ' column to search for duplicates
Dim Source As Worksheet: Set Source = ThisWorkbook.Worksheets("Sheet1")
Dim Duplicates As Worksheet: Set Duplicates = ThisWorkbook.Worksheets("Sheet2")
Dim List As Dictionary: Set List = New Dictionary ' used to hold the first instance of unique items
Dim Data As Variant ' holds a copy of the column you want to search
Dim Count As Integer ' hold the size of said column
Dim Index As Integer ' iterator for data
Dim Item As String ' holds the current item
Count = Source.Cells(Source.Rows.Count, SearchColumn).End(xlUp).Row
Set Data = Source.Range(Source.Cells(1, SearchColumn).Address, Source.Cells(Count, SearchColumn).Address)
Application.ScreenUpdating = False
' first loop, find unique items and copy duplicates
For Index = 1 To Count
Item = Data(Index, 1)
If List.Exists(Item) = False Then
' add the item to our dictionary of items
List.Add Item, Index
Else
' add item to duplicates sheet as its a duplicate
Source.Rows(Index).Copy
Duplicates.Rows(1).Insert xlShiftDown
End If
Next Index
' second loop, remove duplicates from original sheet
For Index = Count To 1 Step -1
Item = Data(Index, 1)
If List.Exists(Item) Then
If Not List(Item) = Index Then
' the item is a duplicate and needs to be removed
Source.Rows(Index).Delete
End If
End If
Next Index
Application.ScreenUpdating = True
End Sub