Deleting rows

[pxtan2]

Hi, I would like to delete any two rows in my data with:

1. Matching cells in column B
2. Equal but opposite cells in another column C

[TABLE="width: 500"]
<tbody>[TR]
[TD]Row
[/TD]
[TD]Source
[/TD]
[TD]Value
[/TD]
[/TR]
[TR]
[TD]1
[/TD]
[TD]S12345678A
[/TD]
[TD]-100
[/TD]
[/TR]
[TR]
[TD]2
[/TD]
[TD]S12345678B
[/TD]
[TD]500
[/TD]
[/TR]
[TR]
[TD]3
[/TD]
[TD]S12345678A
[/TD]
[TD]100
[/TD]
[/TR]
[TR]
[TD]4
[/TD]
[TD]S12345678C
[/TD]
[TD]300
[/TD]
[/TR]
[TR]
[TD]5
[/TD]
[TD]S12345678A
[/TD]
[TD]-100
[/TD]
[/TR]
[TR]
[TD]6
[/TD]
[TD]S12345678B
[/TD]
[TD]-500
[/TD]
[/TR]
</tbody>[/TABLE]


After the deletion the remaining data should be:
[TABLE="width: 500"]
<tbody>[TR]
[TD]Row
[/TD]
[TD]Source
[/TD]
[TD]Value
[/TD]
[/TR]
[TR]
[TD]4
[/TD]
[TD]S12345678C
[/TD]
[TD]300
[/TD]
[/TR]
[TR]
[TD]5
[/TD]
[TD]S12345678A
[/TD]
[TD]-100
[/TD]
[/TR]
</tbody>[/TABLE]


I found a code in this forum which helped to delete rows with equal and opposite cells, so it would be great if just a few modifications to the cells are made.

    'Deleting Duplicate Rows
    
    Dim myRng As Range, c As Range, rOpp As Range
    
    Set myRng = Range("C1", Range("C" & Rows.Count).End(xlUp))
    Application.ScreenUpdating = False
    For Each c In myRng
        If c.Value <> "" Then
            Set rOpp = myRng.Find(What:=-c.Value, LookAt:=xlWhole, _
                SearchFormat:=False)
            If Not rOpp Is Nothing Then
                Union(c, rOpp).ClearContents
            End If
        End If
    Next c
    On Error Resume Next
    myRng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    On Error GoTo 0
    Application.ScreenUpdating = True

Will appreciate any help or assistance. Thanks!

 

[VBA Geek]

Sub Remy()
Dim iRow As Integer
Dim c As Range
Dim addy As String
Dim mVal As Range
iRow = Range("B:B").Find("*", , , , 1, 2).Row
For Each c In Range("B2:B" & iRow).Cells
    If Not c = vbNullString Then
        Set mVal = Range("B2:B" & iRow).Find(c.Value, c, , xlWhole, , 1)
        If Not mVal Is Nothing Then
            If mVal.Offset(, 1) = -c.Offset(, 1) Then
                c.ClearContents
                mVal.ClearContents
            Else
                addy = mVal.Address
                    Do
                        Set mVal = Range("B2:B" & iRow).FindNext(mVal)
                            If mVal.Address = addy Then Exit Do
                            If mVal.Offset(, 1) = -c.Offset(, 1) Then c.ClearContents: mVal.ClearContents: Exit Do
                    Loop Until mVal.Address = addy
            End If
        End If
    End If
Next
If CBool(Evaluate("COUNTBLANK(B2:B" & iRow & ")")) Then: Range("B2:B" & iRow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

 

[pxtan2]

Thank you so much! Worked perfectly.

Sub Remy()
Dim iRow As Integer
Dim c As Range
Dim addy As String
Dim mVal As Range
iRow = Range("B:B").Find("*", , , , 1, 2).Row
For Each c In Range("B2:B" & iRow).Cells
    If Not c = vbNullString Then
        Set mVal = Range("B2:B" & iRow).Find(c.Value, c, , xlWhole, , 1)
        If Not mVal Is Nothing Then
            If mVal.Offset(, 1) = -c.Offset(, 1) Then
                c.ClearContents
                mVal.ClearContents
            Else
                addy = mVal.Address
                    Do
                        Set mVal = Range("B2:B" & iRow).FindNext(mVal)
                            If mVal.Address = addy Then Exit Do
                            If mVal.Offset(, 1) = -c.Offset(, 1) Then c.ClearContents: mVal.ClearContents: Exit Do
                    Loop Until mVal.Address = addy
            End If
        End If
    End If
Next
If CBool(Evaluate("COUNTBLANK(B2:B" & iRow & ")")) Then: Range("B2:B" & iRow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub