从一行中删除重复项答案

【问题标题】：Remove Duplicates From A Row从一行中删除重复项
【发布时间】：2021-01-30 22:19:43
【问题描述】：

我遇到了从单行中删除重复项的问题。我想遍历一个范围内的所有行并从单行中删除重复项，而不影响工作表中的其余数据。这是示例数据：

+---------------+------+------+------+---------------+---------------+
| name          | num1 | num2 | mun3 | emial1        | email2        |
+---------------+------+------+------+---------------+---------------+
| ali zubair    | 1    | 2    | 1    | az@az.com     | az@az.com     |
+---------------+------+------+------+---------------+---------------+
| tosif         | 1    | 2    | 2    | t@zb.com      | t@gb.com      |
+---------------+------+------+------+---------------+---------------+
| qadeer satter | 3    | 2    | 3    | qs@mtm.com    | star@mtn.com  |
+---------------+------+------+------+---------------+---------------+
| asif          | 4    | 3    | 2    |               |               |
+---------------+------+------+------+---------------+---------------+
| hamid         | 1    | 5    | 2    | hamid@beta.ds | hamid@beta.ds |
+---------------+------+------+------+---------------+---------------+

以下代码根据第 2 列删除重复行，不适用于我的情况。

ActiveSheet.Range("A1:f100").RemoveDuplicates Columns:=Array(2), Header:=xlYes

我不知道如何从选定的行范围中删除重复项。到目前为止，我的代码将遍历我的数据中的所有行。

    Sub removeRowDubs()
      Dim nextRang As Range
      Dim sCellStr As String, eCellStr As String
      Dim dRow As Long
       
      dRow = Cells(Rows.Count, 1).End(xlUp).Row
        For dRow = 2 To dRow
               sCellStr = Range("A" & dRow).Offset(0, 1).Address
               eCellStr = Cells(dRow, Columns.Count).End(xlToLeft).Address
               
        Set nextRang = Range(sCellStr, eCellStr)
             Debug.Print nextRang.Address
             
        Next
           
End Sub

所以我需要一些代码来做我需要在下面的代码之后插入的代码。

Set nextRang = Range(sCellStr, eCellStr)

如果有像“.RemoveDuplicates”这样的简单解决方案，请告诉我。到目前为止，我正在考虑通过循环执行此操作，但它似乎很复杂，因为我认为我需要至少 3 个“for each”循环和 3 个“if 条件”，另外 2 个行范围，当我开始这样做时可能还有其他内容。

我希望我的问题已经明确，并且非常感谢您的帮助。我是 Excel VBA 编码的新手，需要您的耐心..

因此，我还编写了删除行重复项的代码。下面是我的代码，它为我工作。它很复杂，而且 stackoverflow 上的人提供了更好的代码。

    Sub removeRowDublicates()
      Dim nextRang As Range                             ' Variables for
      Dim sCellStr As String, eCellStr As String        ' Going through all rows
      Dim dRow As Long                                  ' And selecting row range
        
        dRow = Cells(Rows.Count, 1).End(xlUp).Row    ' This code selects the                                         
        For dRow = 2 To dRow                         ' next row in the data                                                           
               sCellStr = Range("A" & dRow).Offset(0, 1).Address                            
               eCellStr = Cells(dRow, Columns.Count).End(xlToLeft).Address        
        Set nextRang = Range(sCellStr, eCellStr)                                                       
                                                             
         
        Dim aRange As Range, aCell As Range                ' Variables for                               
        Dim dubCheckCell As Range, dubCheckRange As Range  ' Loops to remove
        Dim dubCheckCell1 As Range                         ' Dublicates from                             
        Dim columnNum As Integer                           ' Current row                                
        
           
        Set aRange = nextRang
        columnNum = Range("b2:f2").Columns.Count + 1
        aRange.Select
        
              For Each aCell In aRange    'Loop for selecting 1 cell, if not blank from range to check its value against all other cell values
                      

                                 If aCell.Value <> "" Then
                                    Set dubCheckCell = aCell
                                 Else
                                             GoTo nextaCell   'If current cell is blank then go to next cell in range
                                 End If
                                 
                      If dubCheckCell.Offset(0, 2).Value <> "" Then                   'Selects range by offsetting 1 cell to right from current cell being checked for dublicate value
                   Set dubCheckRange = Range(dubCheckCell.Offset(, 1), dubCheckCell.Offset(, 1).End(xlToRight))
                   Else
                   Set dubCheckRange = Range(dubCheckCell.Offset(0, 1).Address)
                   End If
                                                
                                 
    For Each dubCheckCell1 In dubCheckRange   'Loop that goes through all cells in range selected by above if-statement
      Do While dubCheckCell1.Column <= columnNum
         If dubCheckCell = dubCheckCell1 Then
                 dubCheckCell1.ClearContents
                         Else
                          End If
             GoTo nextdubCheckCell1
             Loop         'For do while
nextdubCheckCell1:
        Next dubCheckCell1            'Next for dubCheckRange
nextaCell:
        Next aCell                    'Next for aRange
              
              Next    'For drow
    
    End Sub

【问题讨论】：

搜索将基于哪些列？ A-D、B-E 或所有列，例如甲乙？列的左侧或右侧是否有必须保留的数据？
从数据中可以看出，重复项遍布行，因此不能基于一列。例如。请参阅第 2 行 - Num1 和 Num3 是重复的，电子邮件 1 和电子邮件 2 也是如此。我的想法是从行中选择 1 个单元格，然后将其与同一行中的所有其他单元格进行检查，如果单元格值等于行中的任何其他单元格，则删除该单元格值。如果不为空，则从行中选择第二个单元格并重复
例如在 Row2 中，命名 ali zubair 选择具有“1”作为值的 cell1，并检查所有剩余的单元格 num2、num3、email1 和 email2。因此，在第 1 步中，从 Num3 列中删除了 1。但这会很复杂，我可以尝试这样做，但想知道是否有任何简单的解决方案。谢谢

标签： excel vba

【解决方案1】：

请尝试下一个代码：

Sub testRemoveRowDuplicates()
  Dim sh As Worksheet, rng As Range, lastRow As Long, i As Long
  
   Set sh = ActiveSheet 'use here your sheet
   lastRow = sh.Range("A" & Rows.Count).End(xlUp).row
  For i = 2 To lastRow
     Set rng = sh.Range("C" & i & ":D" & i)
     rng.Replace rng.Cells(1, 1).Offset(0, -1).Value, "", xlWhole
     Set rng = sh.Range("D" & i)
     rng.Replace rng.Cells(1, 1).Offset(0, -1).Value, "", xlWhole
     Set rng = sh.Range("F" & i)
     rng.Replace rng.Cells(1, 1).Offset(0, -1).Value, "", xlWhole
  Next i
End Sub

以上代码假定电子邮件列中的名称不能重复。它会删除每个类别（姓名和电子邮件）上的重复项。

如果您确实需要检查行的每个值，请使用下一个变体：

Sub testRemoveRowDuplicatesBis()
  Dim sh As Worksheet, rng As Range, lastRow As Long
  Dim i As Long, j As Long
  
   Set sh = ActiveSheet
   lastRow = sh.Range("A" & Rows.Count).End(xlUp).row
  For i = 2 To lastRow
    For j = 3 To 6 'last column
       Set rng = sh.Range(sh.Cells(i, j), sh.Cells(i, 6))
       rng.Replace rng.Cells(1, 1).Offset(0, -1).Value, "", xlWhole
     Next j
  Next i
End Sub

【讨论】：

@Ali Zubair：你有时间检查上面的代码吗？它可以满足您的需要吗？
您好@FaneDuru，您的代码正在运行。它既漂亮又紧凑。我确实编写了自己的代码，并让它删除了重复项，但它既复杂又庞大。谢谢您的帮助。真的很欣赏它

【解决方案2】：

您可以使用一些 VBA 嵌套循环来执行此操作 - 循环行，然后有两个列循环来检查单元格的值：

Sub sRemoveRowDubs()
    On Error GoTo E_Handle
    Dim ws As Worksheet
    Dim lngLastRow As Long
    Dim lngLastCol As Long
    Dim lngRow1 As Long
    Dim lngCol1 As Long
    Dim lngCol2 As Long
    Set ws = Worksheets("Sheet4")
    lngLastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    lngLastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    For lngRow1 = 1 To lngLastRow
        For lngCol1 = 1 To lngLastCol
            For lngCol2 = lngCol1 + 1 To lngLastCol
                If ws.Cells(lngRow1, lngCol1) = ws.Cells(lngRow1, lngCol2) Then
                    ws.Cells(lngRow1, lngCol2) = ""
                End If
            Next lngCol2
        Next lngCol1
    Next lngRow1
sExit:
    On Error Resume Next
    Set ws = Nothing
    Exit Sub
E_Handle:
    MsgBox Err.Description & vbCrLf & vbCrLf & "sRemoveRowDubs", vbOKOnly + vbCritical, "Error: " & Err.Number
    Resume sExit
End Sub

问候，

【讨论】：

您好@Applecore，您的代码也可以正常工作。我也会研究它。感谢您的回复。

【解决方案3】：

如果您可以使用公式并创建一个新表。

Num1列的数组（CSE）公式，在公式栏中输入公式，按control+Shift+Enter然后选择单元格复制到Num2和Num3。然后选择所有三个单元格并向下复制。

=IFERROR(INDEX($B2:$D2,1,MATCH(0,COUNTIF($H2:H2,$B2:$D2),0)),"")

email1 列的数组 (CSE) 公式，在公式栏中输入公式，按 control+Shift+Enter 然后选择单元格复制到 email2。然后选择这两个单元格并向下复制。

=IFERROR(INDEX($E2:$F2,1,MATCH(0,COUNTIF($K2:K2,$E2:$F2),0)),"")

【讨论】：

【解决方案4】：

或者可能是这样的？

Sub test()
Set rngName = Range("A2", Range("A" & Rows.Count).End(xlUp))
For Each cell In rngName
For i = 1 To 4
Set Rng = Range(cell.Offset(0, i + 1), Cells(cell.Row, 6))
Set c = Rng.Find(cell.Offset(0, i).Value, lookat:=xlWhole)
If Not c Is Nothing Then c.ClearContents
Next i
Next cell
End Sub

我在想的是从行中选择 1 个单元格然后检查它 同一行中的所有其他单元格

该代码假定在 NAME 列（A 列）下具有值的行之间不会有空格，并且所有名称值都是唯一的。这是第一个循环。

第二个循环是检查同一行中有多少个单元格，在这种情况下，有 4 个单元格要检查（num1、num2、num3 和 email1）然后检查 4 次 ---> 在同一行：检查 num1 与 num2、num3、email1 和 email2 ... 检查 num2 与 num3、email1 和 email2 .... 检查 num3 与 email1 和 email2 ...然后最后检查 email1 与 email2。在每次检查中，如果找到相同的值，则代码会将找到的单元格留空。

【讨论】：

【解决方案5】：

按行清除重复条目

将完整代码复制到标准模块中（例如Module1）。
只运行第一个Sub，正在调用其他两个。
调整第一个Sub 中的constant，包括工作簿。

守则

Option Explicit

Sub clearDups()
    
    Const wsName As String = "Sheet1"
    Const FirstRowAddress As String = "A2:F2"
    Const LastRowColumn As Long = 1
    Const Replacement As Variant = Empty
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Define Data First Row Range.
    Dim rng As Range: Set rng = wb.Worksheets(wsName).Range(FirstRowAddress)
    ' Define Data Range and write its values to Data Array.
    Dim Data As Variant: getRangeValuesFR Data, rng, LastRowColumn
    If IsEmpty(Data) Then Exit Sub
    ' In data array, clear duplicate values by row
    ' (from the top and from the left).
    replaceDupsByRow Data, Replacement
    ' Write modified values from Data Array to Data Range.
    rng.Resize(UBound(Data)).Value = Data
    
End Sub

Sub getRangeValuesFR(ByRef Data As Variant, _
                     ByRef FirstRowRange As Range, _
                     Optional ByVal LastRowColumn As Long = 1)
    
    Dim rng As Range
    If LastRowColumn = 0 Then GoSub LastRow0 Else GoSub LastRowN
    
    If rng Is Nothing Then Exit Sub
    If rng.Row < FirstRowRange.Row Then Exit Sub
    
    Set rng = FirstRowRange.Resize(rng.Row - FirstRowRange.Row + 1)
    If rng.Row > 1 Then
        Data = rng.Value
    Else
        ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rng.Value
    End If
    
    Exit Sub

LastRow0:
    With FirstRowRange
        Set rng = .Worksheet.Columns(.Column).Resize(, .Columns.Count) _
                  .Find("*", , xlValues, , xlByRows, xlPrevious)
    End With
    Return

LastRowN:
    With FirstRowRange
        Debug.Print .Columns(LastRowColumn).Address
        Set rng = .Worksheet.Columns(.Columns(LastRowColumn).Column) _
                  .Find("*", , xlValues, , , xlPrevious)
    End With
    Return

End Sub

Sub replaceDupsByRow(ByRef Data As Variant, _
                     Optional ByVal Replacement As Variant = Empty)
    
    Dim Curr As Variant, i As Long, j As Long, l As Long
    For i = 1 To UBound(Data)
        For j = 1 To UBound(Data, 2) - 1
            Curr = Data(i, j + 1)
            If Curr <> Replacement Then GoSub loopSubRows
        Next j
    Next i
    Exit Sub

loopSubRows:
    For l = 1 To j
        If Curr = Data(i, l) Then
            Data(i, j + 1) = Replacement: Exit For
        End If
    Next l
    Return

End Sub

【讨论】：

嗨@VBasic2008，感谢您回复我的问题。您的代码也可以正常工作。我很感激。