Excel Перемещение повторяющихся значений на новый лист

Question

Я скомпилировал этот код из бит и кусков, которые я нашел - я отнюдь не эксперт - больше из нетерпеливого ученика. Этот код работает для меня, но теперь мне нужно сохранить первый появление повторяющейся строки для того, чтобы оставаться на исходном листе и перемещать только последующие вхождения (я) на вновь созданный лист.

Я готов повторить весь код, если это необходимо, но предпочел бы, чтобы изменить существующие VBA для времени

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 

Большое спасибо за ваше время и внимание

Answer 1

Вы можете использовать скриптовый словарь объект для отслеживания дубликатов:

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

Другой восторженный любительском Вот!

Не действительно отвечая на ваш вопрос, но вот немного функции я использую для удаления повторяющихся строк:

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 

Когда я получаю сек у меня будет идти адаптировать это к вашим требованиям ...

Answer 3

Это будет искать указанный столбец дубликатов, копирование последующих дубликатов записи до Sheet2, а затем удалите их с Sheet1.

Я также использовал Словарь сценариев, но вам нужно добавить ссылку на «Время выполнения сценариев Microsoft» для того, чтобы код работал как есть. (Добавление ссылка поможет, если вы хотите узнать о словарях, поскольку он добавляет словарь к IntelliType автозавершения кода материалу)

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