Deletion of rows with multiple criteria

[pxtan2]

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!

 

[Gary McMaster]

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:

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]

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]

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:

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

 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]

Sorry the code should be

 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.