Delete Rows with Conditions

[Len]

Hi,

I have at a table below with duplicates of numeric text in column E,
there is no problem using excel formula COUNTIF to remove duplicates
However, if I were to remove each row of duplicates with conditions
that the corresponding value of duplicate in column F is Positive and
also the next value of the same duplicate in the same column F is
negative and both values of that duplicate in column F sum up equal to
zero
In this case, duplicate of 123456 found at E1, E2 and E4 but it has
positive value of 70 at F1 and F2 and also negative value of 70 at F4
Row 1 and 4 will be deleted as the duplicate of 123456 has both value
at F1 ( ie 1st positive value ) & F4 sum up equal to zero
The removal of duplicates will go on until there is no duplicate
found or there is no zero value found after sum up of two duplicate's
value , ie only unique numeric text remain in the table
E.g.
Column E F
Doc No Amt
1 123456 70
2 123456 70
3 654321 -1560
4 123456 -70
5 654321 1560
6 654321 -1560

Result
Doc No Amt
2 123456 70
6 654321 -1560


How to use excel formula or excel vba codes to achieve the result by
removing duplicates with the above conditions

I would be much appreciated if someone could offer a solution to the
above scenario and thanks in advance

Regards
Len

 

[venkat1926]

There is a contradiction in your condition and the result
You say that the first F value should be positive and the sum of the other two should be zero. But in the result you have indicated a negative value.

I have taken whatever the first value the second and third F values should sum up to zero and written a code and the result is as you wanted.

First thing you have to do is
COPY THE DATA IN SHEET 1 IN SHEET 3 SO THAT ORIGINAL DATA IS AVAILABLE SAFELY.



You can modify the macro if necessary.


The macro is “test” (the other macro undo is for undoing the result of the macro)

Sub test()
  Dim r As Range, rfull As Range, rfilt As Range, cfilt As Range, x, r1 As Range, r2 As Range
  Dim c As Range
  Worksheets("sheet1").Activate
  ActiveSheet.UsedRange.Sort key1:=Range("E1"), header:=xlYes
  Set r = Range(Range("E1"), Range("E1").End(xlDown))
  Set rfilt = Range("E1").End(xlDown).Offset(5, 0)
  r.AdvancedFilter action:=xlFilterCopy, copytorange:=rfilt, unique:=True
  Set rfull = Range(Range("E1"), Range("F1").End(xlDown))
  Set rfilt = Range(rfilt.Offset(1, 0), rfilt.End(xlDown))
  For Each cfilt In rfilt
  x = cfilt.Value
  rfull.AutoFilter Field:=1, Criteria1:=x
  Set r1 = ActiveSheet.AutoFilter.Range
  'msgbox  r1.Address
  Set r2 = r1.Offset(1, 0).Resize(r1.Rows.Count - 1, r1.Columns.Count)
  'msgbox  r1.Address
  Set r2 = r2.SpecialCells(xlCellTypeVisible)
  'msgbox  r2.Address
  If r2.Cells(2, 2) + r2.Cells(3, 2) = 0 Then
  Range(r2.Cells(2, 2), r2.Cells(3, 2)).EntireRow.Delete
  End If
  rfull.AutoFilter
  Next cfilt
  Range(Range("E1").End(xlDown).Offset(1, 0), Cells(Rows.Count, "e")).EntireRow.Delete
  Range("E1").Select
  End Sub

Sub undo()
  Worksheets("sheet1").Cells.Clear
  Worksheets("sheet3").Cells.Copy Worksheets("sheet1").Range("A1")
   
  End Sub