连续删除重复的单元格

Posted 2023-03-29

【中文标题】连续删除重复的单元格

【英文标题】：Remove Duplicate Cells in a Row

【发布时间】：2014-03-31 17:14:36

【问题描述】：

只是为了澄清： 我不想删除重复的行，我想删除一行中的重复单元格

所以这是一个经典的地址表，在某些行中有重复的条目 我需要删除这些条目。 我在 VBA 中看到的大部分内容都用于删除列中的重复值，但我找不到删除行中重复值的方法。

Name  |        Address1 |       Address2 |    City |    Country

Peter | 2 foobar street |2 foobar street |  Boston |    USA

我希望它是这样的：

Name  |         Address1 |  Address2 |   City  |    Country

Peter | 2 foobar street  |           |  Boston |    USA

我编写了一个宏，它将遍历所有行，然后遍历每一行的每一列，但我不知道如何在同一行的不同单元格中发现重复项。

代码如下：

Sub Removedupe()   
   Dim LastRow As Long
   Dim LastColumn As Long
   Dim NextCol As Long

   LastRow = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row    
   LastColumn = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

   For counterRow = 1 To LastRow               
       'I'm stuck here: how to remove a duplicate values within that row?         
   Next counterRow   
End Sub

【参考方案1】：

也许这会解决你的问题：

Sub RemoveDuplicatesInRow()

    Dim lastRow As Long
    Dim lastCol As Long
    Dim r As Long 'row index
    Dim c As Long 'column index
    Dim i As Long

    With ActiveSheet.UsedRange
        lastRow = .Row + .Rows.Count - 1
        lastCol = .Column + .Columns.Count - 1
    End With

    For r = 1 To lastRow
        For c = 1 To lastCol
            For i = c + 1 To lastCol 'change lastCol to c+2 will remove adjacent duplicates only
                If Cells(r, i) <> "" And Cells(r, i) = Cells(r, c) Then
                    Cells(r, i) = ""
                End If
            Next i
        Next c
    Next r

End Sub

【讨论】：

做到了！！我已经尝试将每个值都放在一个数组中，但最后你的脚本要快得多，也不那么复杂！！感谢您的帮助

【参考方案2】：

也许这在你的循环中：

If Range("A1").Offset(counterRow,1) = Range("A1").Offset(counterRow,2) Then
    Range("A1").Offset(counterRow,2).Clear
End If

【参考方案3】：

可能最简单的方法是使用字典。读取当前单元格。如果它已经在字典中，则将单元格空白，否则将其添加到字典中。

Dim dict As New Scripting.Dictionary 
For counterRow = 1 To LastRow         
   key = // get the current cell value
   If Not dict.Exists(key) Then 
       dict.Add key, "1"
   Else
      // clear current cell
End If Next counterRow 

这里有更多关于字典的信息： Does VBA have Dictionary Structure?

PS：请注意，我的解决方案会删除所有重复项，而不仅仅是在您的示例中位于第 2 列和第 3 列时。

【参考方案4】：

在您的情况下，重复项是相邻的。对于这种特殊情况，要清除单列或单行中的重复项：

Sub qwerty()
    Dim r As Range, nR As Long
    Set r = Intersect(Cells(13, 1).EntireRow, ActiveSheet.UsedRange)
    nR = r.Count
    For i = nR To 2 Step -1
        If r(i) = r(i - 1) Then
            r(i) = ""
        End If
    Next i
End Sub

此代码是第 13 行的示例