通过比较列来删除excel中的重复行

时间:2016-02-16 08:55:34

标签: excel vba excel-vba

以下是我正在使用的数据示例 如您所见,它有重复的条目。(实际数据库是30000个条目)

我想找到一个关于如何根据列出百分比的相应列删除重复行的方法。

该方法应比较重复行百分比并选择最高行百分比并丢弃另一行

这个问题(初始):
enter image description here

我希望这个输出清楚。 这是结果,我想
enter image description here

任何帮助将不胜感激!

4 个答案:

答案 0 :(得分:3)

试试这个。它将(应该)按电子邮件和百分比列对数据进行排序,然后删除重复项,保留最高百分比。

With ActiveSheet
    .Range("A1:B" & Cells(Rows.Count, "A").End(xlUp).Row).Sort _
        Key1:=Range("A1"), Order1:=xlDescending, Header:=xlYes, KEY2:=Range("B1"), Order2:=xlDescending, Header:=xlYes
    .Range("A1:B" & Cells(Rows.Count, "A").End(xlUp).Row).RemoveDuplicates Columns:=Array(1), Header:=xlYes
End With

答案 1 :(得分:1)

如果您只需手动执行此方法即可。

第1步:按百分比递减排序。

第2步:使用'删除重复项'功能在数据功能区上。在电子邮件中使用它'仅限列。

答案 2 :(得分:1)

1- clic DATA选项卡

enter image description here

2 - 选择您的数据和clic 删除重复项

enter image description here

3 - 选择相应的列,然后单击确定。

答案 3 :(得分:0)

以下是以下帖子的更改版本: Delete all rows if duplicate in excel - VBA

Sub remDup2()
    Dim rng As Range, dupRng As Range, lastrow As Long, ws As Worksheet
    Dim col As Long, col2 As Long, offset As Long, deletecurrent As Boolean

    'Disable all the stuff that is slowing down
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    'Define your worksheet here
    Set ws = Worksheets(1)

    'Define your column and row offset here
    col = 1    'Column with E-Mail
    col2 = 2   'Column with percentage
    offset = 1 'Startrow with entries

    'Find first empty row
    Set rng = ws.Cells(offset + 1, col)
    lastrow = rng.EntireColumn.Find( _
                What:="", After:=ws.Cells(offset + 1, col)).Row - 1

    'Loop through list
    While (rng.Row < lastrow)
        Do
            Set dupRng = ws.Range(ws.Cells(rng.Row + 1, col), ws.Cells(lastrow, col)).Find( _
                    What:=rng, LookAt:=xlWhole)
            If (Not (dupRng Is Nothing)) Then
                If (ws.Cells(rng.Row, col2) > ws.Cells(dupRng.Row, col2)) Then
                    dupRng.EntireRow.Delete
                    lastrow = lastrow - 1
                Else
                    deletecurrent = True
                    Exit Do
                End If
                If (lastrow = rng.Row) Then Exit Do
            Else
                Exit Do
            End If
        Loop

        Set rng = rng.offset(1, 0)

        'Delete current row
        If (deletecurrent) Then
            rng.offset(-1, 0).EntireRow.Delete
            lastrow = lastrow - 1
        End If

        deletecurrent = False
    Wend

    'Enable stuff again
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic

End Sub