Excel Vba-需要从单行中删除重复项

debugcn 发表于 Dev

阿里·祖拜尔

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

+---------------+------+------+------+---------------+---------------+
| name          | num1 | num2 | mun3 | emial1        | email2        |
+---------------+------+------+------+---------------+---------------+
| ali zubair    | 1    | 2    | 1    | [email protected]     | [email protected]     |
+---------------+------+------+------+---------------+---------------+
| tosif         | 1    | 2    | 2    | [email protected]      | [email protected]      |
+---------------+------+------+------+---------------+---------------+
| qadeer satter | 3    | 2    | 3    | [email protected]    | [email protected]  |
+---------------+------+------+------+---------------+---------------+
| asif          | 4    | 3    | 2    |               |               |
+---------------+------+------+------+---------------+---------------+
| hamid         | 1    | 5    | 2    | [email protected] | [email protected] |
+---------------+------+------+------+---------------+---------------+

下面的代码删除基于列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)

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

我还编写了代码，下面提供了代码。它为我工作，但是回答我问题的人提供了更好的代码。

Sub removeRowDuplicates()
      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

雷迪·卢塔纳迪奥（Reddy Lutonadio）

我修改了宏以使用自己的变量。宏通过获取行数和列数来开始。然后在比较值的同时遍历行，列和单元格。如果找到重复值，则将其替换为空值。

Sub removeRowDubs()
  
    Dim dRow As Long
    Dim dCol As Double
    Dim i, j, k As Integer
    Dim rng As Range
   
    i = 1
    dCol = 0
    Set rng = Range(i & ":" & i)
      
    'Get the rows
    dRow = Cells(Rows.Count, 1).End(xlUp).Row
    'Get the columns
    dCol = WorksheetFunction.CountIfs(rng, "<>" & "")
   
    'Contains the value to search
    Dim cvalue As String
  
    'Loop through the rows
    For i = 2 To dRow
        'Loop through the columns
        For j = 2 To dRow
                
            cvalue = Cells(i, j).Value
            'Loop through the cells
            For k = (j + 1) To dCol
        
                If Cells(i, k).Value = cvalue Then
        
                    Cells(i, k).Value = ""
        
                End If
        
            Next
        Next
      Next
           
End Sub

单击以放大gif图像，以查看实际的宏。