Remove range of cells based on unique condition

[kypok999]

Hi Guys,

I have big excel file I have unique ID then client and price the issue i have unique ID can be the same on 7 raws I need to remove all of inuqie ids based if price is lower then 3 but I need to delete all 7 raws as price of first can be 2.94 but second 4.54 see example:

121518578		2.989445
121518578		4.065677
121518578		8.4
121518578		170.6262
121637552		5.855528

<colgroup><col><col span="2"></colgroup><tbody>
</tbody>

So I want to delete top4 and then keep next because Price is over 5.8

Thank u

 

[JLGWhiz]

You would get better responses if you identified the sheet name and columns in which your data is located. Based on your example, you want to evaluate only the first occurrence of each unique ID and either delete or keep all other rows with that ID, regardless of the price on the following occurrences of the same ID. Is that correct?

 

[JLGWhiz]

This assumes the data is in columns A and B. You can try it on a copy of your file or a mock up to see if it is what you want. Copy the code to your code module1.

Sub t()
Dim sh As Worksheet, c As Range, fn As Range, lr As Long
Set sh = ActiveSheet
With sh
    .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).AdvancedFilter xlFilterCopy, , .Cells(Rows.Count, 2).End(xlUp)(3), True
    For Each c In .Cells(Rows.Count, 2).End(xlUp).CurrentRegion.Offset(1)
        lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
        If c <> "" Then
        Set fn = .Range("A2:A" & lr).Find(c.Value, , xlValues)
            If Not fn Is Nothing Then
                If fn.Offset(, 1).Value < 3 Then
                    .Range("A1:A" & lr).AutoFilter 1, c.Value
                    .Range("A2:A" & lr).SpecialCells(xlCellTypeVisible).Delete xlShiftUp
                    .AutoFilterMode = False
                End If
            End If
        End If
    Next
    .Cells(Rows.Count, 2).End(xlUp).CurrentRegion.ClearContents
End With
End Sub

 

[kypok999]

Thank you JLGWhiz it seems to work the only thing that i should have mentioned i have more data then column a and b sorry i have as in picture from raw A to AC and the unique id is in column D and price is in column Q I attached picture I want if criteria is met and price is less then 3 then all raws with that unique id to be deleted from as in example below i want A2:AC14 to be deleted

https://imgur.com/a/xTmN7

Thank you very much

 

[JLGWhiz]

Thank you JLGWhiz it seems to work the only thing that i should have mentioned i have more data then column a and b sorry i have as in picture from raw A to AC and the unique id is in column D and price is in column Q I attached picture I want if criteria is met and price is less then 3 then all raws with that unique id to be deleted from as in example below i want A2:AC14 to be deleted

https://imgur.com/a/xTmN7

Thank you very much

the code has been modified per post #4 . Re-test it before applying it to your original file.

Sub t2()
Dim sh As Worksheet, c As Range, fn As Range, lr As Long
Set sh = ActiveSheet
With sh
    .Range("D1", .Cells(Rows.Count, 4).End(xlUp)).AdvancedFilter xlFilterCopy, , .Cells(Rows.Count, 2).End(xlUp)(3), True
    For Each c In .Cells(Rows.Count, 2).End(xlUp).CurrentRegion.Offset(1)
        lr = sh.Cells(Rows.Count, 4).End(xlUp).Row
        If c <> "" Then
        Set fn = .Range("D2:A" & lr).Find(c.Value, , xlValues)
            If Not fn Is Nothing Then
                If fn.Offset(, 13).Value < 3 Then
                    .Range("A1:AC" & lr).AutoFilter 4, c.Value
                    .Range("A2:AC" & lr).SpecialCells(xlCellTypeVisible).Delete xlShiftUp
                    .AutoFilterMode = False
                End If
            End If
        End If
    Next
    .Cells(Rows.Count, 2).End(xlUp).CurrentRegion.ClearContents
End With
End Sub

 

[kypok999]

Thank you ver much vba is working!!!

 

[JLGWhiz]

Thank you ver much vba is working!!!

You are welcome,
regards, JLG

 

[kypok999]

Hi Jlg I've run it again as not everything was removed but now it has deleted all the data.. I uploaded the file were I want this to work maybe you can check please

https://drive.google.com/file/d/0B01EVJq4OV8vQkgwd1NxemVHdXM/view?usp=sharing