Remove duplicate in below cell, stop if cell is blank

[JTSID]

I am looking for a way to remove duplicates from a column. I know how to do it from the end of column up, but I need the first instant of the value to stay. Also I need the code to stop once it hits an empty cell. Column is segmented into different section spit by empty cell. I do not want to shift cells up.

Example 1:

T204 Center Drill
T201 Rough Turn
T201 Rough Turn
T201 Rough Turn

End Results:
T204 Center Drill
T201 Rough Turn

Example 2 with blank cell in between:
T204 Center Drill
T201 Rough Turn

T201 Rough Turn
T201 Rough Turn

End Results:
T204 Center Drill
T201 Rough Turn

T201 Rough Turn

Thank You,

JT

 

[lrobbo314]

There might be a more eloquent solution to this, but this seems to work. Make a copy of your workbook and test the code out on the copy.

Sub removeDupes()


Dim r As Range
Dim cel As Range

Set cel = Range("A7") 'Set to first cell in first column

Do Until cel.Value = ""
    Set r = cel.CurrentRegion
    r.RemoveDuplicates 2, xlNo
    Set cel = r.Cells(1, 1)
    Set cel = cel.End(xlDown)
    Set cel = cel.End(xlDown)
Loop

End Sub

 

[lrobbo314]

This solution is a bit better. Should be faster over large datasets and wont run into having multiple blank rows between groups like the first solution does.

You will need to go into the VB Editor and add a reference to Microsoft Scripting Runtime for it to work.

Sub removeDupesII()
Dim SD As New Dictionary
Dim LR As Long
Dim cnt As Long
Dim r As Range
Dim AR()
Dim Res()

cnt = 1
LR = Range("A" & Rows.Count).End(xlUp).Row()

Set r = Range("A7:B" & LR)
AR = r.Value

For i = 1 To UBound(AR)
    If AR(i, 1) <> "" And i <> UBound(AR) Then
        If Not SD.Exists(AR(i, 1)) Then
            SD.Add AR(i, 1), AR(i, 2)
        End If
    Else
        For j = 0 To SD.Count - 1
            ReDim Preserve Res(1 To cnt)
            Res(cnt) = SD.Keys(j) & "|" & SD.Items(j)
            cnt = cnt + 1
        Next j
        SD.RemoveAll
        ReDim Preserve Res(1 To cnt)
        Res(cnt) = ""
        cnt = cnt + 1
    End If
Next i

r.ClearContents
Set r = r.Resize(UBound(AR) - 1, 1)
r.Value = Application.Transpose(Res)
r.TextToColumns Destination:=r.Cells(1, 1), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="|", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True

End Sub