VBA удалить строки, которые смещают друг друга

Question

Я пытаюсь исключить позиции, которые отменяют друг друга.

Например, ниже будут удалены две строки, которые добавляют к нулю (т. Е. 87,1 и -87,1).

-87.1

890

87.1

898989

Код, который я использую, в основном работает, но в тех случаях, когдаЕсть множество строк с одинаковыми значениями, которые удаляются все вместо одного подходящего значения для одного наблюдения.Например, ниже, я хотел бы, чтобы он отменил два из -87.1 и два из 87.1, но один будет оставшимся, потому что нет никакого числа, непосредственно смещающего его.

-87.1

890

87.1

898989

87.1

-87.1

-87.1

---

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 x()

Dim ar() As Variant
Dim i As Integer
Dim j As Integer
Dim n As Integer

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))"

ar = ActiveSheet.Range("AV2:AV" & last).Value

For i = LBound(ar) To UBound(ar)

        For j = LBound(ar) To UBound(ar)
            If i <> j Then

                If ar(i, 1) = ar(j, 1) Then

                ar(i, 1) = ""
                ar(j, 1) = ""

                End If
            End If
        Next

Next

For i = LBound(ar) To UBound(ar)

   ActiveSheet.Range("AV" & i + 1).Value = ar(i, 1)

Next

ActiveSheet.Range("AV2:AV" & last).SpecialCells(xlCellTypeBlanks).Delete xlUp

End Sub

Я пробовал и проверял это.

Answer 2

Вы можете попробовать:

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

Answer 3

Я думаю, вам нужно что-то вроде этого:

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