VBA：根據列Q中的最低價格刪除列S中的重複條目（行）

Question

我是vba的新手，在前面得到了一些關於vba宏的幫助，現在我需要幫助。

我有一個Excel文件，數據量很大，而且在S列中有大量重複的EAN編號，我想刪除所有重複的EAN（整個行與重複項），但保留最低價格的列（列Q），因此我想比較列S中的重複EAN，並根據列Q中的最低價格刪除所有重複項，並保留最低價格。它有很多數據，超過10000行，所以通過formel手動執行此操作並不是最佳方式，需要大量時間手動刪除這些行。下面

例子（第一個是價格和第二應該是一個EAN）：

1. 104,93 - 000000001
2. 104.06 - 000000001
3. 104.94 - 000000001

在此如果我想刪除第一行和第三行並保留第二行，任何人都知道宏應該如何，我使用Excel 2010？

Answer 1

這可能會幫助你。

我假設你有一個標題行。如果不是，則將iHeaderRowIndex更改爲0。

第一部分是創建一個字典對象，收集所有獨特的EAN號碼，併爲每個EAN它分配一個非常高的價格（10元）

然後重新掃描清單，這一次做了「MIN」邏輯來確定每個EAN的最低價格。

另一個重新掃描，這次它會在每個分鐘EAN旁邊的空白列中放一個MIN標記（您應該選擇一個空列和空列的名稱 - 我放入「W」但您可以更改它）

最後，它以相反的順序重新掃描列表以刪除所有沒有MIN標記的行。最後，它還會刪除MIN標記的列。

Public Sub DoDelete() 
Dim oWS As Worksheet 
Dim d As Object, k As Object 
Dim a As Range 
Dim b As Range 
Dim sColumnForMarking As String 
Dim iHeaderRowIndex As Integer 
Dim i As Integer 
Dim iRowsCount As Integer 
Dim v As Double 


Set oWS = ActiveSheet 
Set d = CreateObject("scripting.dictionary") 

' ----> Put here ZERO if you do not have a header row !!! 
iHeaderRowIndex = 1 
' ----> Change this to what ever you like. This will be used to mark the minimum value. 
sColumnForMarking = "W" 

' Selecting the column "S" 
Set a = _ 
oWS.Range(oWS.Cells(1 + iHeaderRowIndex, "S"), _ 
      oWS.Cells(ActiveSheet.UsedRange.Rows.Count, "S")) 

' putting a high number, one that is beyond the max value in column Q 
' ----> Change it if it is too low !!!! 
For Each b In a 
    d(b.Text) = 9999999 ' very high number, A max++ to all the prices 
Next 

For Each b In a 
    v = CDbl(oWS.Cells(b.Row, "Q").Value) 

    If v < CDbl(d(b.Text)) Then 
     d(b.Text) = v 
    End If 
Next 

For Each b In a 
    v = CDbl(oWS.Cells(b.Row, "Q").Value) 

    If v = CDbl(d(b.Text)) Then 
     oWS.Cells(b.Row, sColumnForMarking).Value = "MIN" 
    End If 
Next 


' This part deletes the lines that are not marked as "MIN". 

iRowsCount = oWS.UsedRange.Rows.Count 

Application.ScreenUpdating = False 

For i = iRowsCount To iHeaderRowIndex + 1 Step -1 
    If oWS.Cells(i, sColumnForMarking).Text <> "MIN" Then 
     oWS.Rows(i).Delete Shift:=xlShiftUp 
    End If 
Next 

' clean up- deletes the mark column 
oWS.Columns(sColumnForMarking).EntireColumn.Delete 

Application.ScreenUpdating = True  
End Sub