delete row based a 4 cell criteria

[ppirkle]

I am needing help on macro: Search in column "a" for set of duplicates, macro will then review column "k".
Criteria for deletion if duplicates are present and column "k" of these duplicates both equal value of $0.00, then delete row. If both not $0.00 then move on to next until finished with entire sheet.

Delete
A K
585706000 $0.00
585706000 $0.00

Don't delete
A K
585706000 ($778.09)
585706000 $0.00

 

[venkat1926]

I have put a sample data as follows in sheet1. copy the data in sheet 1 in sheet 2 also

Excel Workbook
	A	B	C	D	E	F	G	H	I	J	K
1	dataA	dataB	dataC	dataD	daaE	dataF	dataG	dataH	dataI	dataJ	dataK
2	1	x	x	x	x	x	x	x	x	x	1.00
3	1	x	x	x	x	x	x	x	x	x	1.00
4	2	x	x	x	x	x	x	x	x	x	2.00
5	2	x	x	x	x	x	x	x	x	x	3.00
6	3	x	x	x	x	x	x	x	x	x	4.00
7	3	x	x	x	x	x	x	x	x	x	4.00
8	4	x	x	x	x	x	x	x	x	x	4.00
9	5	x	x	x	x	x	x	x	x	x	6.00
10	5	x	x	x	x	x	x	x	x	x	7.00
11	6	x	x	x	x	x	x	x	x	x	7.00
Sheet1

now run the macro test and check. if you want to retest
run undo first and then the macro test.

Sub test()
Dim r As Range, filt As Range, uniq As Range, cuniq As Range
Worksheets("sheet1").Activate
ActiveSheet.AutoFilterMode = False
Set r = Range("A1").CurrentRegion
'MsgBox r.Address
Set uniq = Range("A1").End(xlDown).Offset(5, 0)
uniq = Range("A1").Value
uniq.Offset(0, 1) = Range("K1").Value
r.AdvancedFilter xlFilterCopy, , Range(uniq, uniq.Offset(0, 1)), True
Set uniq = Range(uniq.Offset(1, 0), uniq.End(xlDown))
For Each cuniq In uniq
Range("A1").Select
Selection.AutoFilter
 Selection.AutoFilter field:=Range("A1").Column, Criteria1:=cuniq.Value, Operator:=xlAnd
 Selection.AutoFilter field:=Range("K1").Column, Criteria1:=WorksheetFunction.Text(cuniq.Offset(0, 1).Value, "0.00")
If r.SpecialCells(xlCellTypeVisible).Rows.Count > 2 Then
r.Offset(1, 0).Resize(r.Rows.Count - 1, r.Columns.Count).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End If
ActiveSheet.AutoFilterMode = False
Next cuniq
Range(Range("A1").End(xlDown).Offset(1, 0), Cells(Rows.Count, "A")).EntireRow.Delete
End Sub

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

End Sub

 

[venkat1926]

there is a bug in the macro test. delete that macro and replace by this testone

Sub testone()
Dim r As Range, filt As Range, uniq As Range, cuniq As Range
Worksheets("sheet1").Activate
ActiveSheet.AutoFilterMode = False
Set r = Range("A1").CurrentRegion
'MsgBox r.Address
Set uniq = Range("A1").End(xlDown).Offset(5, 0)
uniq = Range("A1").Value
uniq.Offset(0, 1) = Range("K1").Value
r.AdvancedFilter xlFilterCopy, , Range(uniq, uniq.Offset(0, 1)), True
Set uniq = Range(uniq.Offset(1, 0), uniq.End(xlDown))
For Each cuniq In uniq
Range("A1").Select
Selection.AutoFilter
 Selection.AutoFilter field:=Range("A1").Column, Criteria1:=cuniq.Value, Operator:=xlAnd
 Selection.AutoFilter field:=Range("K1").Column, Criteria1:=WorksheetFunction.Text(cuniq.Offset(0, 1).Value, "0.00")
If r.Offset(1, 0).Resize(r.Rows.Count - 1, r.Columns.Count).SpecialCells(xlCellTypeVisible).Rows.Count > 1 Then
r.Offset(1, 0).Resize(r.Rows.Count - 1, r.Columns.Count).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End If
ActiveSheet.AutoFilterMode = False
Next cuniq
Range(Range("A1").End(xlDown).Offset(1, 0), Cells(Rows.Count, "A")).EntireRow.Delete
End Sub

 

[Rick Rothstein]

if duplicates are present and column "k" of these duplicates both equal value of $0.00, then delete row.

Some questions....

1) In the above quoted section, you say "delete row"... singular... which of the two rows did you want deleted, the first or second? Or did you actually mean rows and you want both rows deleted?

2) Could there be more than two "duplicates"?

3) Will your data be sorted when the macro runs? If not, is it alright for the macro to sort it for you?

4) Are the values in Columns A and K constant values or formulas?

 

[ppirkle]

1) Delete both rows
2) Never more than 2 duplicates
3) I will have it sorted so that duplicates are together
4) Always constants: Col A will be just numbers and Col K will be currency

 

[Rick Rothstein]

1) Delete both rows
2) Never more than 2 duplicates
3) I will have it sorted so that duplicates are together
4) Always constants: Col A will be just numbers and Col K will be currency

Okay, give this macro a try...

Sub DeleteDuplicateRowsWithZeroValues()
  Dim Index As Long
  Const StartRow As Long = 1
  Application.ScreenUpdating = False
  Index = StartRow
  Do While Index < Cells(Rows.Count, "A").End(xlUp).Row
    If Cells(Index, "A").Value = Cells(Index + 1, "A").Value Then
      If Cells(Index, "K").Value = 0 And Cells(Index + 1, "K").Value = 0 Then
        Cells(Index, "A").Resize(2).Value = "#N/A"
        Index = Index + 1
      End If
    End If
    Index = Index + 1
  Loop
  On Error Resume Next
  Columns("A").SpecialCells(xlConstants, xlErrors).EntireRow.Delete
  Application.ScreenUpdating = True
End Sub

 

[ppirkle]

You are amazing, thanks for the help. It works great!!!!!