VBA to remove duplicate cells under certain criteria

[jack2]

Hi all!

I need help writing a script that duplicate cells in a column IF:
- Action 2 contains "delete one"
- Serial(1) is NOT BLANK
The cells with the arrows indicate which one I want to remove.

Before

Outcome/Goal

Thanks!

 

[Peter_SSs]

Welcome to the MrExcel board!

1. Will you ever have any rows where Action 2 contains "delete one" and Serial(1) IS BLANK?

2. Can you post the sample data again in a way we can copy/paste to test with. Helpers in general would not want to have to type out that much data to develop a solution.
My signature block below has a link with help about how to do it.

 

[jack2]

Welcome to the MrExcel board!

1. Will you ever have any rows where Action 2 contains "delete one" and Serial(1) IS BLANK?

2. Can you post the sample data again in a way we can copy/paste to test with. Helpers in general would not want to have to type out that much data to develop a solution.
My signature block below has a link with help about how to do it.

Thank you for the kind welcome.

1. There will be rows where Action 2 contains "delete one" and Serial(1) IS BLANK, but they must be skipped and/or considered!

2. Sure thing! Here's the link to the file - https://1drv.ms/x/s!ArRB1Ah3M1ZqgpkTd2hM1A8HaTvqSw

 

[Peter_SSs]

There will be rows where Action 2 contains "delete one" and Serial(1) IS BLANK, but they must be skipped and/or considered!

The red part is confusing. To me ..
- if they are skipped then they are not considered
- if they are considered then they are not skipped.

In addition, there were no rows like that in your sample data.

In any case, try this with a copy of your workbook.

Sub DeleteRows()
  Dim d As Object
  Dim a As Variant, b As Variant
  Dim lr As Long, nc As Long, i As Long, k As Long
  
  Const Serial1Col As String = "E"
  Const Action2Col As String = "P"
  
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Set d = CreateObject("Scripting.Dictionary")
  With ActiveSheet
    If .FilterMode Then .ShowAllData
    lr = .Range(Serial1Col & .Rows.Count).End(xlUp).Row
    nc = .Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
    a = Application.Index(.Cells, Evaluate("row(2:" & lr & ")"), Array(Columns(Serial1Col).Column, Columns(Action2Col).Column))
    ReDim b(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
      If a(i, 2) Like "delete one*" Then
        If Len(a(i, 1)) > 0 Then
          If d.exists(a(i, 1)) Then
            k = k + 1
            b(i, 1) = 1
          Else
            d(a(i, 1)) = 1
          End If
        End If
      End If
    Next i
    If k > 0 Then
      With .Range("A2").Resize(UBound(a), nc)
        .Columns(nc).Value = b
        .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo, _
              OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
        .Resize(k).EntireRow.Delete
      End With
    End If
  End With
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub

 

[jack2]

The red part is confusing. To me ..
- if they are skipped then they are not considered
- if they are considered then they are not skipped.

In addition, there were no rows like that in your sample data.

In any case, try this with a copy of your workbook.

Sub DeleteRows()
  Dim d As Object
  Dim a As Variant, b As Variant
  Dim lr As Long, nc As Long, i As Long, k As Long
  
  Const Serial1Col As String = "E"
  Const Action2Col As String = "P"
  
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Set d = CreateObject("Scripting.Dictionary")
  With ActiveSheet
    If .FilterMode Then .ShowAllData
    lr = .Range(Serial1Col & .Rows.Count).End(xlUp).Row
    nc = .Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
    a = Application.Index(.Cells, Evaluate("row(2:" & lr & ")"), Array(Columns(Serial1Col).Column, Columns(Action2Col).Column))
    ReDim b(1 To UBound(a), 1 To 1)
    For i = 1 To UBound(a)
      If a(i, 2) Like "delete one*" Then
        If Len(a(i, 1)) > 0 Then
          If d.exists(a(i, 1)) Then
            k = k + 1
            b(i, 1) = 1
          Else
            d(a(i, 1)) = 1
          End If
        End If
      End If
    Next i
    If k > 0 Then
      With .Range("A2").Resize(UBound(a), nc)
        .Columns(nc).Value = b
        .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo, _
              OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
        .Resize(k).EntireRow.Delete
      End With
    End If
  End With
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub

The code worked! Though, I still do have a question or two.

How would I modify this, to only just delete the cell value in E (for the duplicate) and not delete the whole row? Additionally, how would I modify it, to work for Action 3?

Thank you.

 

[Peter_SSs]

How would I modify this, to only just delete the cell value in E (for the duplicate) and not delete the whole row?

Code would be quite different. Try

Sub ClearCells()
  Dim d As Object
  Dim a As Variant
  Dim lr As Long, i As Long
  
  Const Serial1Col As String = "E"
  Const Action2Col As String = "P"
  
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Set d = CreateObject("Scripting.Dictionary")
  With ActiveSheet
    If .FilterMode Then .ShowAllData
    lr = .Range(Serial1Col & .Rows.Count).End(xlUp).Row
    a = Application.Index(.Cells, Evaluate("row(2:" & lr & ")"), Array(Columns(Serial1Col).Column, Columns(Action2Col).Column))
    With .Range(Serial1Col & 2, .Range(Serial1Col & lr))
      For i = 1 To UBound(a)
        If a(i, 2) Like "delete one*" Then
          If Len(a(i, 1)) > 0 Then
            If d.exists(a(i, 1)) Then
              .Cells(i).ClearContents
            Else
              d(a(i, 1)) = 1
            End If
          End If
        End If
      Next i
    End With
  End With
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub

Additionally, how would I modify it, to work for Action 3?

What do you mean "work for Action 3"?
There is nothing in Action 3 column and I don't know what might be there or what you want to happen if there was something there.

 

[jack2]

What do you mean "work for Action 3"?
There is nothing in Action 3 column and I don't know what might be there or what you want to happen if there was something there.

Your code worked perfectly. You are a genius.

By Action 3, I mean, similar conditions to Action 2 (but different column):
- If duplicate serial numbers (Column E) are found AND
- If the value "Delete One" is found in the Action 3 Column for those duplicates, Then
- Clear the serial number from the cell in column E (not remove the entire row) for the duplicates

Example data - https://1drv.ms/x/s!ArRB1Ah3M1ZqgpkTd2hM1A8HaTvqSw (Same file)

 

[Peter_SSs]

Your code worked perfectly.

Great news!

By Action 3, I mean, similar conditions to Action 2 (but different column):
- If duplicate serial numbers (Column E) are found AND
- If the value "Delete One" is found in the Action 3 Column for those duplicates, Then
- Clear the serial number from the cell in column E (not remove the entire row) for the duplicates

I think that you will have to make just 2 changes.

1.The first should be fairly obvious

<del>Const Action2Col As String = "P"</del>
Const Action2Col As String = "Q"

2. For the second change you have a choice. Either ..
a) Change your formulas in column R of 'DUP' to say "delete one cancelled" instead of "Delete one cancelled" (as my code looks for lower case only)

or

b) add the blue text to this line of the code

If LCase(a(i, 2)) Like "delete one*" Then

 

[jack2]

Great news!


I think that you will have to make just 2 changes.

1.The first should be fairly obvious

<del>Const Action2Col As String = "P"</del>
Const Action2Col As String = "Q"

2. For the second change you have a choice. Either ..
a) Change your formulas in column R of 'DUP' to say "delete one cancelled" instead of "Delete one cancelled" (as my code looks for lower case only)

or

b) add the blue text to this line of the code

If LCase(a(i, 2)) Like "delete one*" Then

Thank you again =). I Appreciate you taking your time out to help.

 

[Peter_SSs]

Thank you again =). I Appreciate you taking your time out to help.

No problem, glad to help.