Excel 将重复值移动到新值 sheet
Excel Moving duplicate values to new sheet
我根据发现的点点滴滴编译了这段代码 - 我绝不是专家 - 更像是一个热心的学生 - 这段代码对我有用，但现在我需要保留第一次出现的重复行保留原始作品sheet，仅将后续出现的作品移至新创作的作品sheet。
如果需要，我愿意重做所有代码，但为了节省时间，我更愿意修改现有的 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
非常感谢您的时间和考虑
这里又是一位热心的业余爱好者！
没有真正回答你的问题，但这里有一个我用来删除重复行的小函数：
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
等我有空时，我会根据您的要求进行调整...
您可以使用脚本字典对象来跟踪重复项：
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
这将在指定列中搜索重复项，将后续重复项复制到 Sheet2，然后从 Sheet1 中删除它们。
我也使用过脚本词典，但您需要添加对 "Microsoft Scripting Runtime" 的引用才能使代码按原样工作。 （如果您想了解字典，添加参考会有所帮助，因为它将字典添加到 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
我根据发现的点点滴滴编译了这段代码 - 我绝不是专家 - 更像是一个热心的学生 - 这段代码对我有用，但现在我需要保留第一次出现的重复行保留原始作品sheet，仅将后续出现的作品移至新创作的作品sheet。
如果需要，我愿意重做所有代码，但为了节省时间，我更愿意修改现有的 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
非常感谢您的时间和考虑
这里又是一位热心的业余爱好者！
没有真正回答你的问题，但这里有一个我用来删除重复行的小函数：
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
等我有空时，我会根据您的要求进行调整...
您可以使用脚本字典对象来跟踪重复项：
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
这将在指定列中搜索重复项，将后续重复项复制到 Sheet2，然后从 Sheet1 中删除它们。
我也使用过脚本词典，但您需要添加对 "Microsoft Scripting Runtime" 的引用才能使代码按原样工作。 （如果您想了解字典，添加参考会有所帮助，因为它将字典添加到 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