Deletion of rows with multiple criteria

pxtan2

New Member
Joined
Apr 4, 2014
Messages
11
Hi guys, I have just started to learn excel vba, so please do bear with me here. I have a large sheet of data, and will require a macro to delete any two rows with opposite but equal amount in the cells of the fourth column, but provided that both rows start with S in the cells of the second column. Taking the below table as an example,
No.
Code
Name
Amount
1
54321
John
-1000
2
S12345678C
John
1000
3
S12345678A
John
-500
4
S12345678B
John
500

<tbody>
</tbody>

After running the code I will need the remaining data to be:
No.
Code
Name
Amount
1
54321
John
-1000
2
S12345678C
John
1000

<tbody>
</tbody>

with both third and fourth rows deleted.

Will appreciate any help or assistance. Thanks a lot!
 

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.

Gary McMaster

Well-known Member
Joined
Feb 8, 2009
Messages
1,977
Welcome to the board!

Try the following sample in a standard module. It depends on the entire data set being structured as you have shown. That is: the positive and negative values of the same absolute value are in adjacent rows.

As shown the code will not delete anything. Please un-comment the indicated line to actually delete data.

I hope it helps.

Gary


In a standard module:

Code:
Public Sub Test()

Dim oCell As Range
Dim oDelete As Range
Dim lLastRow As Long

'Last used row in column A
lLastRow = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row

Set oCell = ActiveSheet.Range("B1")

Do Until oCell.Address = ActiveSheet.Range("B" & lLastRow + 1).Address

    If Left(oCell.Value, 1) = "S" And Left(oCell.Offset(1, 0).Value, 1) = "S" Then
        If oCell.Offset(0, 2).Value + oCell.Offset(1, 2).Value = 0 Then
            If Not oDelete Is Nothing Then
                Set oDelete = Union(oDelete, oCell.EntireRow, oCell.Offset(1, 0).EntireRow)
            Else
                Set oDelete = Union(oCell.EntireRow, oCell.Offset(1, 0).EntireRow)
            End If
        End If
    End If
    
    Set oCell = oCell.Offset(1, 0)
    
Loop

If Not oDelete Is Nothing Then
    oDelete.Interior.ColorIndex = 3
    'Un-comment next line to actually delete rows
    'oDelete.Delete xlUp
End If

End Sub
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
49,413
Office Version
  1. 365
Platform
  1. Windows
A welcome to the MrExcel board from me too!

A further question:
With your sample data, could it ever be possible that say row 5 has S12345678C in col 2 and 500 or -500 in col 4? If so, it would also be "opposite" either No 3 or No 4 so would that mean all 3 rows would be deleted because they are all "opposite" of another row?
 

pxtan2

New Member
Joined
Apr 4, 2014
Messages
11
Hi Gary and Peter, thanks so much for the assistance. Sorry for the late reply since I couldn't access my work files from home over the weekend.

Anyway I realized I was unclear in the description of my problem here.

Let me rephrase my data set again for better clarity:

No.
Code
Name
Amount
1
S12345678C
John
1000
2
S12345678E
John
-300
3
S12345678A
John
-500
4
S12345678B
John
500
5
54321
John
-1000

<tbody>
</tbody>

The positive and negative values of the same absolute value are NOT in adjacent rows, i.e. They can be anywhere in the data sheet, some rows may be pairs, while others may not, such as row 2 above.

Anyway I also realized that I was wrong in my earlier request: when two rows have opposite but equal amount in the cells of the fourth column, but one do not start with S in the cells of the second column, delete that row, and leave the one with S in the cell of second column untouched.

Hence the data should look like (after running the code):

No.
Code
Name
Amount
1
S12345678C
John
1000
2
S12345678E
John
-300

<tbody>
</tbody>


Just to address Peter's question, it is highly unlikely for three same rows to have opposite values, so it should not be a problem. There is also no two rows with opposite values in column 4 but do not start with S in column 2.

I searched through some old threads and found this code to be useful:
Code:
Sub DeleteZeroSumRows()
CC = "K" 'column to check
With ActiveSheet
    LR = .Cells(Rows.Count, CC).End(xlUp).Row 'last row in Column to check
    For r = LR To 2 Step -1
        pr = r - 1
        For rr = pr To 1 Step -1
              
                If .Cells(r, CC) = -(.Cells(rr, CC)) And UCase(Left(Cells(r, "E").Text, 1)) = "S" Then
               
                .Rows(r).Delete
                .Rows(rr).Delete
                Exit For
                
            End If
        Next rr
    Next r
End With
End Sub

However it showed the Run-time error '13': Type mismatch error when I tried to run it and this line
Code:
 If .Cells(r, CC) = -(.Cells(rr, CC)) And UCase(Left(Cells(r, "E").Text, 1)) = "S" Then
was highlighted yellow.

I suspect that this may be due to the heading of the data being non-numerical, so is there anyway to get over this error? In addition it doesn't address my criteria regarding the presence of "S" in the second column.

Sorry for the wall of words as I'm trying to be as clear to avoid any confusion.

Again, thanks so much for the help and assistance in advance! :)
 

pxtan2

New Member
Joined
Apr 4, 2014
Messages
11
Sorry the code should be
Code:
 Sub DeleteZeroSumRows()
CC = "D" 'column to check
With ActiveSheet
    LR = .Cells(Rows.Count, CC).End(xlUp).Row 'last row in Column to check
    For r = LR To 2 Step -1
        pr = r - 1
        For rr = pr To 1 Step -1
              
                If .Cells(r, CC) = -(.Cells(rr, CC)) And UCase(Left(Cells(r, "B").Text, 1)) = "S" Then
               
                .Rows(r).Delete
                .Rows(rr).Delete
                Exit For
                
            End If
        Next rr
    Next r
End With
End Sub
It should be columns D and B for the second and fourth lines of code.
 

Forum statistics

Threads
1,136,285
Messages
5,674,848
Members
419,530
Latest member
undisclosed

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top