Question

我需要微调我的代码以删除除上次发生之外的所有重复项。重复项将由多个列（A列，B列，C列）定义。下一列始终具有不同的数字，因此在定义重复项时将被忽略。我需要删除整行。在单元格比较旁边过滤和进行单元格也不起作用，因为它不知道哪一个是最后出现的。 See example table

Sub DuplicateDelete()
Dim Rng     As Range
Dim Dn      As Range
Dim nRng    As Range
Dim Q       As Variant
Dim K       As Variant
With Sheets("Sheet1")
Set Rng = .Range(.Range("A9:C9"), .Range("A" & Rows.Count).End(xlUp))
 End With
  On Error Resume Next
  Rng.SpecialCells(xlCellTypeBlanks).Resize(, Columns.Count).Delete
    On Error GoTo 0
    With CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
For Each Dn In Rng
    If Dn <> "" Then
    If Not .Exists(Dn.Value) Then
        .Add Dn.Value, Array(Nothing, Dn)
    Else
        Q = .Item(Dn.Value)
            If nRng Is Nothing Then
                Set Q(0) = Q(1)
                Set Q(1) = Dn
                Set nRng = Q(0)
            Else
                Set Q(0) = Q(1)
                Set nRng = Union(nRng, Q(0))
                Set Q(1) = Dn
            End If
        .Item(Dn.Value) = Q
      End If
End If
Next
If Not nRng Is Nothing Then
nRng.EntireRow.Delete
End If
End With
End Sub

例如，在上面的列表中，我需要删除顶部的2行，因为它们是最后2行的副本。我只需要一个扫描所有行的扫描程序，并决定删除除最后一次出现之外的所有重复项。有可能吗？提前感谢您的帮助。

*注意：这不是我自己的代码，我是VBA的初级，它是从搜索中引用的。

Answer 1

不确定我是否遗漏了一些明显的东西，但是你不会自下而上地循环，如果你遇到了你已经遇到过的价值组合，那么就删除那一行。 / p>

如果您使用Collection，则可以创建3个值的字符串键，例如＆＃34; 173 | 4566 | 3＆＃34;如果该密钥已存在，则表示您有重复。

此外，可以更快地一次删除一行而不是一行。

总而言之，您的代码可能是：

Const START_ROW As Long = 9
Dim v As Variant
Dim i As Long, r As Long
Dim key As String
Dim delRows As Range
Dim uniques As Collection
Dim exists As Boolean

' Read the values into an array
With Sheet1
    v = .Range(.Cells(START_ROW, "A"), _
               .Cells(.Rows.Count, "A").End(xlUp)) _
               .Resize(, 3).Value2
End With

Set uniques = New Collection

For i = UBound(v, 1) To 1 Step -1

    key = CStr(v(i, 1)) & "|" & _
          CStr(v(i, 2)) & "|" & _
          CStr(v(i, 3))
    exists = False

    'Test if key exists
    On Error Resume Next
    exists = uniques(key)
    On Error GoTo 0

    If exists Then 'we have a duplicate to be deleted
        r = i + START_ROW - 1
        If delRows Is Nothing Then
            Set delRows = Sheet1.Cells(r, 1)
        Else
            Set delRows = Union(delRows, Sheet1.Cells(r, 1))
        End If
    Else 'we have a new unique item
        uniques.Add True, key
    End If

Next

'Delete the duplicate rows
If Not delRows Is Nothing Then
    delRows.EntireRow.Delete
End If

Answer 2

添加临时栏
使用数字系列填充临时列
排序温度列降序
清除温度栏
删除重复项
添加临时栏
使用数字系列填充临时列
排序临时列升序
清除温度栏

$(document).ready(function(){

	window.setInterval(sliduh1, 3000);

	var slide = $('.activeSlide');

});

function sliduh1() {
		var currentSlide = $('.activeSlide');
		var nextSlide = currentSlide.next();

		if (nextSlide.length === 0 ) {
			nextSlide = $('.slide').first();
		}

		currentSlide.fadeOut(600).removeClass('activeSlide');
		nextSlide.fadeIn(600).addClass('activeSlide');
}

Answer 3

非常感谢您的回答。抱歉无法及早回复，昨天遇到了一些连接问题，所以我自己试了几件事。我最后以略微不同的方式使用了类似的逻辑。制作下面的一个我完全翻转数据表的地方，然后使用excel的内置“删除重复”功能，然后再次翻转数据。这让我按照自己的意愿保持最后一次出现。

这是每张工作簿的循环函数。

Function Dup_removal_Repeat_all_sheets(i)
'first flip data tables upside down, as excel's duplicate delete works
  'only downwards, but we want to keep latest duplicate addition
    Dim vTop As Variant
    Dim vEnd As Variant
    Dim iStart As Integer
    Dim iEnd As Integer
    Sheets(i).Select
         Range("A10:J10").Select
    Range(Selection, Selection.End(xlDown)).Select
        Application.ScreenUpdating = False
        iStart = 1
        iEnd = Selection.Rows.Count
        Do While iStart < iEnd
            vTop = Selection.Rows(iStart)
            vEnd = Selection.Rows(iEnd)
            Selection.Rows(iEnd) = vTop
            Selection.Rows(iStart) = vEnd
            iStart = iStart + 1
            iEnd = iEnd - 1
        Loop
        Application.ScreenUpdating = False
'Now scan top to bottom to delete duplicates
         Range("A10:J10").Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveSheet.Range("$A$10:$J$2000").RemoveDuplicates Columns:=Array(1, 2, 3), _
        Header:=xlNo
'Flip data tables back
         Range("A10:J10").Select
    Range(Selection, Selection.End(xlDown)).Select
        Application.ScreenUpdating = False
        iStart = 1
        iEnd = Selection.Rows.Count
        Do While iStart < iEnd
            vTop = Selection.Rows(iStart)
            vEnd = Selection.Rows(iEnd)
            Selection.Rows(iEnd) = vTop
            Selection.Rows(iStart) = vEnd
            iStart = iStart + 1
            iEnd = iEnd - 1
        Loop
        Application.ScreenUpdating = True
End Function

唯一的问题是，它会擦除所有表格单元格中的公式，我做的一个解决方法是从流程中排除第一行（第9行），然后在流程结束时，将其自动填充到最后一行数据，在所有列中。对于重复扫描，我给出了2000行的任意值（不会是这种情况，但是以后不必编辑它）。

删除重复行，但上次出现除外 - VBA Excel 2013

3 个答案: