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
CodePudding user response:
Maybe this will do the trick
Function RemoveDupeLine() As String
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)
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
c.Value = txt
txt = ""
Set coll = Nothing
End If
Next
End Function
good lock
CodePudding user response:
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::*=.)]"))
Also, if you have the latest office 365 insiders version, you could replace FILTERXML
with the new TEXTSPLIT
function.