title: Excel Moving duplicate values to new sheet
body: <p>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. </p>
  
  <p>I am willing to redo all the code if needed but would prefer to modify the existing vba for the sake of time</p>
  
  <pre><code>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 " &amp; 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 &lt;&gt; 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 &lt;&gt; Addresses(0) 'Until we get back to the original address
  
              If UBound(Addresses) &gt; 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" &amp; pRow).Value = "Duplicate Rows for Value " &amp; c.Value &amp; _
                            " in Column " &amp; c.Column &amp; " 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
  </code></pre>
  
  <p>Thank you very much for your time and consideration</p>