如何刪除具有條件的範圍中的乘法行？

Question

我有一個表有行ID，我想刪除每個行ID與基於價格標準相同的行ID。

我能刪除行，但如何將我刪除，如果它是乘法

如果價格= 700，刪除行ID的3和4的整個範圍。我可以刪除具有700的行，但不知道如何刪除具有相同ID的其他行。

for i = 1 to 10 
    if cells(i,3).value = 700 then 
     cells(i,3).EntireRow.Delete 
     'how to delete the other row that has the same row id? 
    End if 
next i 

Answer 1

曾在我的小測試：

Sub DeleteRows() 

    Dim rng As Range, rw As Range, k, dict, x As Long 
    Dim rngDelete As Range 

    Set dict = CreateObject("scripting.dictionary") 

    Set rng = ActiveSheet.Range("A1").CurrentRegion 

    'first pass - find all "duplicate" id's 
    For x = 2 To rng.Rows.Count 
     Set rw = rng.Rows(x) 
     k = rw.Cells(1) & "~" & rw.Cells(2) 
     If Application.CountIfs(rng.Columns(1), rw.Cells(1), _ 
           rng.Columns(3), rw.Cells(3)) > 1 Then 
      rw.Interior.Color = vbYellow '<<< for QC 
      dict.Add k, True '<<remember this combination 
     End If 
    Next x 
    'second pass - flag rows for deletion 
    For x = 2 To rng.Rows.Count 
     Set rw = rng.Rows(x) 
     k = rw.Cells(1) & "~" & rw.Cells(2) 
     If dict.exists(k) Then BuildRange rngDelete, rw 
    Next x 

    If Not rngDelete Is Nothing Then rngDelete.Delete 

End Sub 

Sub BuildRange(ByRef rngTot As Range, ByRef rngAdd As Range) 
    If Not rngTot Is Nothing Then 
     Set rngTot = Application.Union(rngTot, rngAdd) 
    Else 
     Set rngTot = rngAdd 
    End If 
End Sub 

Answer 2

希望這樣的事情能夠適應您的需求：

Sub tgr() 

    Const sIDCol As String = "B" 
    Const sPriceCol As String = "C" 

    Dim ws As Worksheet 
    Dim rCheck As Range 
    Dim rCheckCell As Range 
    Dim rDel As Range 

    Set ws = ActiveWorkbook.ActiveSheet 
    Set rCheck = ws.Range(ws.Cells(1, sPriceCol), ws.Cells(ws.Rows.Count, sPriceCol).End(xlUp)) 

    For Each rCheckCell In rCheck.Cells        'Loop through each cell in rCheck 
     If rCheckCell.Value = 700 Then        'If the cell = 700 
      Select Case ws.Cells(rCheckCell.Row, sIDCol).Value 
       Case 3, 4           'And the cell in column sIDCol in the same row = 3 or 4 
        If rDel Is Nothing Then       'then add the cell to the rDel range 
         Set rDel = rCheckCell 
        Else 
         Set rDel = Union(rDel, rCheckCell) 
        End If 

       Case Else 
        'Do nothing 

      End Select 
     End If 
    Next rCheckCell 

    If Not rDel Is Nothing Then rDel.EntireRow.Delete    'If there's anything in the rDel range, delete those rows 

End Sub