How to delete data on pre-defined preference of values

[ThrottleWorks]

Hi,

Please refer attached file for your reference.
I am trying to delete data as per seniority order.
Please note, values will not be sorted in real scenario.

Can anyone please help me in this.

 

[PCosta87]

Hi,

If you intend to delete everything with Sr. >1 then i believe this will do, even if the data is not ordered:

Sub delete()

    On Error Resume Next
    Dim c As Range
   
    For Each c In ActiveSheet.Columns("A").Cells
        If c.Value = 1 Or c.Value = "Sr." Or c.Value = "" Then
        Resume Next
        Else
            c.EntireRow.ClearContents
        End If
    Next

End Sub

But for some reason I feel this isn't what you are looking for...
Please let me know if it helped

 

[ThrottleWorks]

Hi @PCosta87 , thanks for the help.
My mistake, serial number is not present in real scenario.

Good night.

 

[PCosta87]

no problem...

So, if we don't have sr. number, does that mean you want to delete everything except the first row in each "box"? Is the first row always the one to keep?

Please advise

and good night

 

[Chihiro]

Will need actual data set/structure to give you code that fits your need. But without using "Sr." it would be something like below with current data.

Sub Test()
Dim lRow As Long, i As Long, j as Long
Dim dict As Object

Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = 1

lRow = Cells(Rows.Count, 3).End(xlUp).Row

For i = 2 To lRow
    If Cells(i, 3).Value <> "Part" Then
        dict.Item(Cells(i, 3).Value) = 1
    End If
Next

For j = lRow To 2 Step -1
    If dict.Item(Cells(j, 3).Value) = 1 Then
        dict.Item(Cells(j, 3).Value) = 0
    ElseIf Cells(j, 3).Value = "Part" Then
    Else
        Cells(j, 3).EntireRow.ClearContents
    End If
Next
  

End Sub

 

[ThrottleWorks]

Hi @Chihiro sir, extremely sorry for late reply. I am checking this and will revert with details.

Have a nice day ahead.

 

[ThrottleWorks]

Hi @Chihiro sir, please find attached edited sample data for your reference.
Apologies for confusion and your time spent earlier on this.

 

[Chihiro]

What's the logic for picking Crankshaft over Piston?

Is there list of output priority? If there is one, it's easy enough to do. But without it, I'm not sure what your logic for picking one over the other would be.

 

[ThrottleWorks]

Yes @Chihiro sir, it is as per priority.

1 Block
2 Crankshaft
3 Piston
4 Piston ring

 

[Chihiro]

One more question. Should output be altering original input or placed elsewhere? Such as new sheet.

 

[ThrottleWorks]

Hi @Chihiro sir, thanks a lot for the help. Output should replace original input.
For example, original raw data has 20 rows, processed data has 5 rows.

This new data of 5 rows should replace 20 rows.

Have a nice day ahead.

 

[Chihiro]

Bit of kludge. But test it out.

Sub Test()
Dim bdict As Object, cdict As Object
Dim faddress As String
Dim c As Range, d As Range
Dim minK As Integer: minK = 99
Dim i As Integer: i = 1
Dim rEmpty As Integer

Set bdict = CreateObject("Scripting.Dictionary")
Set cdict = CreateObject("Scripting.Dictionary")
cdict.CompareMode = 1
With cdict
    .Add Item:=1, Key:="Block"
    .Add Item:=2, Key:="Crankshaft"
    .Add Item:=3, Key:="Piston"
    .Add Item:=4, Key:="Piston ring"
End With

With ActiveSheet.UsedRange
    Set c = .Find("Bike", LookIn:=xlValues, SearchOrder:=xlByColumns)
    If Not c Is Nothing Then
        faddress = c.Address
        Do
            bdict.Add Item:=c, Key:=i
            i = i + 1
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> faddress
    End If
End With

Application.ScreenUpdating = False

For Each Key In bdict.Keys
    With bdict.Item(Key)
        rEmpty = .End(xlDown).Row
        For j = 1 To rEmpty - .Row
            If cdict.exists(.Offset(j, 1).Value) Then
                If minK > cdict.Item(.Offset(j, 1).Value) Then
                    minK = cdict.Item(.Offset(j, 1).Value)
                    Set d = .Offset(j).Resize(1, 2)
                End If
            End If
        Next
        minK = 99
        d.Copy .Offset(1)
        If rEmpty - .Row - 1 >= 1 Then
            .Offset(2).Resize(rEmpty - .Row - 1, 2).Delete Shift:=xlUp
        End If
    End With
Next
Application.ScreenUpdating = True
End Sub

 

[ThrottleWorks]

Hi @Chihiro sir, thanks lot for the help. I am checking this and will revert with details.

Have a nice day ahead.

 

[ThrottleWorks]

Hi @Chihiro sir, it is working nice, thanks a lot.

Have a nice day ahead.