Deleting this duplicates without shifting the cells

[Coyotex3]

How can I accomplish this? Column B will always have duplicate values and I want to remove the duplicates but with a catch.

Book1
	A	B	C
1	Order Type	Name	Number
2	First	John	45654
3	Second	John	45665
4	Third	John	45878
5	First	Jack	56887
6	Second	Jack	54513
7	Third	Jack	15687
8	First	James	78954
9	Second	James	65895
10	Third	James	23564
11	First	Jane	23545
12	Second	Jane	12562
13	Third	Jane	12564
14	First	Jose	12357
15	Second	Jose	45879
16	Third	Jose	15877
17	First	Helen	15448
18	Second	Helen	65897
19	Third	Helen	78884
20	fourth	Helen	45658
21	First	James	87945
22	Second	James	46593
23	Third	James	32148
Sheet4

I want the end result to look like this. Essentially trying to delete duplicate values on Column B ONLY IF they are in successive rows. i,e if I see James on Rows 2,3,4, 21,22,23 I want to delete James from Rows 3,4 and 22,23 without shifting the cells to look like this

Book1
	A	B	C	D
1	Order Type	Name	Number
2	First	John	45654
3	Second		45665
4	Third		45878
5	First	Jack	56887
6	Second		54513
7	Third		15687
8	First	James	78954
9	Second		65895
10	Third		23564
11	First	Jane	23545
12	Second		12562
13	Third		12564
14	First	Jose	12357
15	Second		45879
16	Third		15877
17	First	Helen	15448
18	Second		65897
19	Third		78884
20	fourth		45658
21	First	James	87945
22	Second		46593
23	Third		32148
24
Sheet4

Any thoughts?

 

[Trebor76]

Hi Coyotex3,

Try this:

Option Explicit
Sub Macro1()

    Dim ws As Worksheet
    Dim lngRow As Long, lngLastRow As Long
    Dim clnNames As New Collection
    
    Application.ScreenUpdating = False
    
    Set ws = ThisWorkbook.Sheets("Sheet1") '<-Sheet name containing data. Change to suit if necessary.
    lngLastRow = ws.Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    For lngRow = 2 To lngLastRow
        On Error Resume Next
            clnNames.Add CStr(ws.Range("B" & lngRow)), ws.Range("B" & lngRow)
            If Err.Number <> 0 Then
                ws.Range("B" & lngRow).ClearContents
            End If
        On Error GoTo 0
    Next lngRow
    
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

 

[Ezguy4u]

Coyotex because you can never have too many solutions, here is another.

Sub Clear3()
Dim CellCnt As Integer

CellCnt = Cells(Rows.Count, "A").End(xlUp).Row

For i = CellCnt To 2 Step -1

Cells(i, 2).Select

If Cells(i, 2) Like Cells(i - 1, 2) Then
    Selection.ClearContents
End If

Next i

End Sub

 

[Coyotex3]

Guys thank you so much. I’m out and about right now. Once I get back home I’ll reply to you both! Really appreciate the help guys!!!

 

[Trebor76]

Thanks Ezguy4u - I think I overcomplicated things.

Hi Coyotex3,

Try this simplified code:

Option Explicit
Sub Macro2()

    Dim ws As Worksheet
    Dim lngRow As Long, lngLastRow As Long
    
    Application.ScreenUpdating = False
    
    Set ws = ThisWorkbook.Sheets("Sheet1") '<-Sheet name containing data. Change to suit if necessary.
    lngLastRow = ws.Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    For lngRow = 2 To lngLastRow
        If StrConv(ws.Range("A" & lngRow), vbProperCase) <> "First" Then
           ws.Range("B" & lngRow).ClearContents
        End If
    Next lngRow
    
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

 

[Coyotex3]

Hi Coyotex3,

Try this:

Option Explicit
Sub Macro1()

    Dim ws As Worksheet
    Dim lngRow As Long, lngLastRow As Long
    Dim clnNames As New Collection
  
    Application.ScreenUpdating = False
  
    Set ws = ThisWorkbook.Sheets("Sheet1") '<-Sheet name containing data. Change to suit if necessary.
    lngLastRow = ws.Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  
    For lngRow = 2 To lngLastRow
        On Error Resume Next
            clnNames.Add CStr(ws.Range("B" & lngRow)), ws.Range("B" & lngRow)
            If Err.Number <> 0 Then
                ws.Range("B" & lngRow).ClearContents
            End If
        On Error GoTo 0
    Next lngRow
  
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

I could not get this one to work for some reason. I keep getting

Hi Coyotex3,

Try this:

Option Explicit
Sub Macro1()

    Dim ws As Worksheet
    Dim lngRow As Long, lngLastRow As Long
    Dim clnNames As New Collection
   
    Application.ScreenUpdating = False
   
    Set ws = ThisWorkbook.Sheets("Sheet1") '<-Sheet name containing data. Change to suit if necessary.
    lngLastRow = ws.Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
   
    For lngRow = 2 To lngLastRow
        On Error Resume Next
            clnNames.Add CStr(ws.Range("B" & lngRow)), ws.Range("B" & lngRow)
            If Err.Number <> 0 Then
                ws.Range("B" & lngRow).ClearContents
            End If
        On Error GoTo 0
    Next lngRow
   
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

Hi Robert, thank you for this one. This one works well. I did run into some issues when trying to run the macro and the data was different (same format) it would give me an error. However you answered the original question and gave me what I needed THANK YOU!!!!

 

[Coyotex3]

Coyotex because you can never have too many solutions, here is another.

Sub Clear3()
Dim CellCnt As Integer

CellCnt = Cells(Rows.Count, "A").End(xlUp).Row

For i = CellCnt To 2 Step -1

Cells(i, 2).Select

If Cells(i, 2) Like Cells(i - 1, 2) Then
    Selection.ClearContents
End If

Next i

End Sub

This one works as well! This one was able to run through a different set of data(similar format, much larger) without any issues. THANK YOU!!!

 

[Coyotex3]

Thanks Ezguy4u - I think I overcomplicated things.

Hi Coyotex3,

Try this simplified code:

Option Explicit
Sub Macro2()

    Dim ws As Worksheet
    Dim lngRow As Long, lngLastRow As Long
   
    Application.ScreenUpdating = False
   
    Set ws = ThisWorkbook.Sheets("Sheet1") '<-Sheet name containing data. Change to suit if necessary.
    lngLastRow = ws.Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
   
    For lngRow = 2 To lngLastRow
        If StrConv(ws.Range("A" & lngRow), vbProperCase) <> "First" Then
           ws.Range("B" & lngRow).ClearContents
        End If
    Next lngRow
   
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

Hey Robert, With this one I keep getting a subscript out of range message if I try to run the macro with different data(same format). I'll read up on this error, as I'm unfamiliar with errors in general.

 

[Coyotex3]

Coyotex because you can never have too many solutions, here is another.

Sub Clear3()
Dim CellCnt As Integer

CellCnt = Cells(Rows.Count, "A").End(xlUp).Row

For i = CellCnt To 2 Step -1

Cells(i, 2).Select

If Cells(i, 2) Like Cells(i - 1, 2) Then
    Selection.ClearContents
End If

Next i

End Sub

In my dataset (3k rows) I have some typos such as in row 1 I might have "John Doe" in row 2 " Jonh Doe" and in row 3 "JOHN DOE" is there a way of making the macro delete those rows as well even those they are not exact?

 

[Trebor76]

Hey Robert, With this one I keep getting a subscript out of range message if I try to run the macro with different data(same format). I'll read up on this error, as I'm unfamiliar with errors in general.

That error message is usually when the code is told to work with a specific tab but it doesn't exist in the workbook. Make sure the sheet name in the following is exactly how it is in the workbook (check also for leading or trailing spaces):

Set ws = ThisWorkbook.Sheets("Sheet1") '<-Sheet name containing data. Change to suit if necessary.

Robert