Remove duplicate lines, only per each cell on a column

user_15586050 0
Viewed 127

enter image description here

I have duplicates lines on each cell, these lines are merely URL address separated by vbLf.
I need to remove duplicate lines, but only per each cell on the column.
I found the below function, but it removes words only per each cell.
In advance, grateful for any helpful comments and answers. 

Function RemoveDupeWords(text As String, Optional delimiter As String = " ") As String
    Dim dictionary As Object
    Dim x, part
 
    Set dictionary = CreateObject("Scripting.Dictionary")
    dictionary.CompareMode = vbTextCompare
    For Each x In Split(text, delimiter)
        part = Trim(x)
        If part <> "" And Not dictionary.Exists(part) Then
            dictionary.Add part, Nothing
        End If
    Next
 
    If dictionary.Count > 0 Then
        RemoveDupeWords = Join(dictionary.keys, delimiter)
    Else
        RemoveDupeWords = ""
    End If
 
    Set dictionary = Nothing
End Function
vba excel
2 Answers

Maybe this will do the trick

    sub RemoveDupeLine() 
  
    Dim coll As Collection
    
    Dim i As Long, c, txt As String, arr As Variant
    
    Dim rng As Range: Set rng = ThisWorkbook.Worksheets(1).Range("A1").CurrentRegion
    
    For Each c In rng
        Set coll = New Collection
        arr = Split(c.Value, vbLf)
          For i = LBound(arr) To UBound(arr)
    ' Here's the trick. For a collection in this insert mode it cannot accept duplicate key entries. And in that I instruct him to ignore the error, he accumulates only unique values and move on.
                On Error Resume Next
                  coll.Add Item:=arr(i), Key:=arr(i)
                On Error GoTo 0
          Next i
          
       If coll.Count > 0 Then
            For i = 1 To coll.Count
               txt = txt & coll(i) & vbLf
            Next i
       End If
         c.Value = txt
         txt = ""
        Set coll = Nothing
        
    Next
     
End sub

good luck

user_55690080

If you have Windows Excel 2019+, you can do this with a formula:

=TEXTJOIN(CHAR(10),,FILTERXML("<t><s>"& SUBSTITUTE(A2,CHAR(10),"</s><s>")& "</s></t>","//s[not (preceding::*=.)]"))

enter image description here

Also, if you have the latest office 365 insiders version, you could replace FILTERXML with the new TEXTSPLIT function.

user_28729220
Related