Question

我正在尝试消除相互抵消的订单项。

例如，将添加到零的两行下方的内容删除（即87.1和-87.1）。

我正在使用的代码大多数都有效，但是在有很多行具有相同值的情况下，它将删除所有行，而不是每次观察仅匹配一个值。例如，在下面，我希望它抵消掉-87.1s中的两个和87.1s中的两个，但是由于没有直接抵消它的数字，所以将剩下一个。

Sub x()
    Dim n As Long, rData As Range

    Application.ScreenUpdating = False

    n = Range("C" & Rows.Count).End(xlUp).Row
    Range("AV2:AV" & n).Formula = "=IF(I2=0,0,COUNTIFS($C$2:$C$" & n & ",C2,$I$2:$I$" & n & ",-I2))"

    With ActiveSheet
        .AutoFilterMode = False
        .Rows(1).AutoFilter field:=48, Criteria1:=">0"
        With .AutoFilter.Range
            On Error Resume Next
            Set rData = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
            If Not rData Is Nothing Then
                rData.EntireRow.Delete shift:=xlUp
            End If
        End With
        .AutoFilterMode = False
    End With

    Application.ScreenUpdating = True

End Sub

Answer 1

我认为您需要这样的东西：

Sub DeleteOppositeNumbers()
    Dim Fnd As Range, r As Long
    'By: Abdallah Ali El-Yaddak
    Application.ScreenUpdating = False
    'Loop through the column bottom to top.
    For r = Range("C" & Rows.Count).End(xlUp).Row To 2 Step -1
        If Cells(r, 3).Value > 0 Then 'If the value is positive
            'Sreach for it's opposite
            Set Fnd = Columns(3).Find(-Cells(r, 3).Value, LookAt:=xlWhole) 
            'If found, delete both.
            If Not Fnd Is Nothing Then Rows(r).Delete: Fnd.EntireRow.Delete 
        End If
    Next
    'Just to restore normal behaviour of sreach
    Set Fnd = Columns(3).Find(Cells(3, 2).Value, LookAt:=xlPart)
    Application.ScreenUpdating = True
End Sub

Answer 2

也许更简单一些：

我已经尝试并测试过这个。

Answer 3

您可以尝试：

Option Explicit

Sub test()

    Dim arr As Variant
    Dim LastRow As Long, i As Long, j As Long

    With ThisWorkbook.Worksheets("Sheet1")

        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        arr = Range("A1:A" & LastRow)

        For i = UBound(arr) To LBound(arr) Step -1
            For j = UBound(arr) - 1 To LBound(arr) Step -1
                If arr(i, 1) + arr(j, 1) = 0 Then
                    .Rows(i).EntireRow.Delete
                    .Rows(j).EntireRow.Delete
                    Exit For
                End If
            Next j
        Next i

    End With

End Sub

VBA删除彼此偏移的行

3 个答案: