Question

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

+---------------+------+------+------+---------------+---------------+
| 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个“每个”循环和3个“如果条件”循环，另外2个行范围，以及在我开始那样做时可能还有其他事情。

我希望我的问题很清楚，非常感谢您的帮助。我是Excel VBA编码的新手，需要您的耐心。

因此，我还研究了删除行重复项的代码。下面是我的代码，它对我有用。这很复杂，而且堆栈溢出的人们提供了更好的代码。

    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

Answer 1

您可以使用一些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

此致

Answer 2

请尝试下一个代码，

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

Answer 3

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

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

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

电子邮件1的数组（CSE）公式列，在公式栏中输入公式，按Control + Shift + Enter，然后选择要复制到email2的单元格。然后选择这两个单元格并向下复制。

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

Answer 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进行比较。在每次检查中，如果找到相同的值，则代码会将空白置于找到的单元格中。

Answer 5

按行清除重复条目

将完整的代码复制到标准模块中（例如Module1）。
仅运行第一个Sub，而其他两个则被调用。
调整第一个Sub中的 const 蚂蚁，包括工作簿。

代码

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: Call 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).
    Call 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

连续删除重复项

5 个答案:

按行清除重复条目