刪除重複行，並留下具體排座椅後面

Question

我在下面的示例中的格式日期：

ABC 001

ABC 002

ABC 003

ABC 004

我想刪除列A中的重複行，但保留列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