Question

我的日期格式如下：

ABC 001

ABC 002

ABC 003

ABC 004

我想删除A列中的duplcate行但是在B列中保留最高值的行（在本例中为004）。简单的重复删除不能让我控制不删除哪个值（除非我遗漏了什么）。

这是更大的VBA代码的一部分，因此，我想通过VBA来实现。我非常感谢任何帮助。

Answer 1

假设列B包含数值，则可以使用下面的代码删除所有非最大重复项。然而，这可以对数据进行排序，因为它将信息加载到一个数组中，该数组可以跟踪B列中哪个值最大。

Sub RemoveDuplicates()
    Dim sht As Worksheet
    Dim NonDupArr() As Variant
    Dim i As Integer
    Dim j As Integer
    Dim EntryFound As Boolean

    Set sht = ActiveSheet

    'Reads range into an array and retains the records with the largest value
    For i = 2 To sht.Cells(sht.Rows.Count, 1).End(xlUp).Row Step 1
        EntryFound = False

        'If first entry
        If i = 2 Then
            ReDim Preserve NonDupArr(1 To 2, 1 To 1)
            NonDupArr(1, 1) = sht.Cells(i, 1).Value
            NonDupArr(2, 1) = sht.Cells(i, 2).Value
        'For all other entries
        Else
            'Loops through array to see if entry already exist
            For j = LBound(NonDupArr, 2) To UBound(NonDupArr, 2)
                If sht.Cells(i, 1).Value = NonDupArr(1, j) Then
                    'If enty exists it replaces the value from column B if larger than
                    'the entry allready in the array
                    If sht.Cells(i, 2).Value > NonDupArr(2, j) Then
                        NonDupArr(2, j) = sht.Cells(i, 2).Value
                    End If
                    EntryFound = True
                    Exit For
                End If
            Next j

            'If no entry were found it will be added to the array
            If Not EntryFound Then
                ReDim Preserve NonDupArr(1 To 2, 1 To UBound(NonDupArr, 2) + 1)
                NonDupArr(1, UBound(NonDupArr, 2)) = sht.Cells(i, 1).Value
                NonDupArr(2, UBound(NonDupArr, 2)) = sht.Cells(i, 2).Value
            End If
        End If
    Next i

    'Loops through the sheet and removes all rows that doesn't match rows in the array
    For i = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row To 2 Step -1
        'Searches for match in array
        For j = LBound(NonDupArr, 2) To UBound(NonDupArr, 2)
            'If this is not the largest entry then the row is removed
            If sht.Cells(i, 1).Value = NonDupArr(1, j) And sht.Cells(i, 2).Value <> NonDupArr(2, j) Then
                sht.Cells(i, 1).EntireRow.Delete
                Exit For
            End If
        Next j
    Next i
End Sub

删除重复的行并留下特定的行

1 个答案: