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

Row	Source	Value
1	S12345678A	-100
2	S12345678B	500
3	S12345678A	100
4	S12345678C	300
5	S12345678A	-100
6	S12345678B	-500

<tbody>
</tbody>

After the deletion the remaining data should be:

Row	Source	Value
4	S12345678C	300
5	S12345678A	-100

<tbody>
</tbody>

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