仅清除相邻的重复项答案

【问题标题】：Clear adjacent duplicates only仅清除相邻的重复项
【发布时间】：2023-01-02 05:51:08
【问题描述】：

此子清除两列之间的重复行。

如果它在 F 和 G 列中找到一个新的对，它将在整个 F 和 G 中清除该对。

我正在尝试清除直接低于原始值的值。

我试图在清除重复项后进行重置，这样它就不会清除不直接低于原始值的值。

Sub clearDups1()

    Dim lngMyRow As Long
    Dim lngMyCol As Long
    Dim lngLastRow As Long
    Dim objMyUniqueData As Object
   
    Application.ScreenUpdating = False

    lngLastRow = Range("F:G").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
   
    Set objMyUniqueData = CreateObject("Scripting.Dictionary")
   
    For lngMyRow = 1 To lngLastRow 'Assumes the data starts at row 1. Change to suit if necessary.
        If objMyUniqueData.Exists(CStr(Cells(lngMyRow, 6) & Cells(lngMyRow, 7))) = False Then
            objMyUniqueData.Add CStr(Cells(lngMyRow, 6) & Cells(lngMyRow, 7)), Cells(lngMyRow, 6) & Cells(lngMyRow, 7)
        Else
            Range(Cells(lngMyRow, 6), Cells(lngMyRow, 7)).ClearContents
        End If
    Next lngMyRow
   
    Set objMyUniqueData = Nothing
   
    Application.ScreenUpdating = True
   
End Sub

任何意见表示赞赏。

【问题讨论】：

标签： excel vba

【解决方案1】：

你不需要字典：

Sub clearDups1()

    Dim lngMyRow As Long, lngLastRow As Long, ws As Worksheet
    Dim k As String, kPrev As String
    
    Set ws = ActiveSheet
    lngLastRow = ws.Range("F:G").Find("*", SearchOrder:=xlByRows, _
                                      SearchDirection:=xlPrevious).row
   
    Application.ScreenUpdating = False
    kPrev = Chr(0) 'won't occur in your data
    For lngMyRow = 1 To lngLastRow 'Assumes the data starts at row 1. Change to suit if necessary.
        k = CStr(ws.Cells(lngMyRow, 6).Value) & "<>" & CStr(ws.Cells(lngMyRow, 7).Value)
        If kCurr = k Then 'same as previous row?
            ws.Cells(lngMyRow, 6).Resize(1, 2).ClearContents
        End If
        kPrev = k 'set as key for previous row
    Next lngMyRow
    Application.ScreenUpdating = True
End Sub

【讨论】：

【解决方案2】：

您也可以尝试此代码。它做你所要求的。

留下第一次出现的相同复制品

从底部开始删除它们并留下最终的，在我们的例子中将是原始的

使用上述方法，您可以实现您所要求的。

Sub clearDups() 
    Dim lR As Long, r As Long 
    Dim x As 99999 
    Dim f(x), g(x) As String 
    Dim lRow As Long, lCol As Long, i As Long 
    lRow = Range("F" & Rows.Count).End(xlUp).Row 
    For lR = 2 To lRow 
        f(lR - 1) = Cells(lR, "F").Value 
        g(lR - 1) = Cells(lR, "G").Value 
    Next 
    For Each s In f 
        i = i + 1 
        If Application.CountIf(Range("F1:G" & lRow), s) = 2 Then 
            Cells(i, "F").Value = "" 
            Cells(i, "G").Value = "" 
        End If 
    Next 
End Sub

【讨论】：