# Fastest function to Remove Duplicate Lines per each cell

The below function is used to Remove Duplicate Lines per each cell.
It works without problem, but it is slow with a range of only one column and 17k rows.
Actually, (with the same range in addition to another two column) , I am using a different excellent code by @VBasic2008 Link which perform complex tasks than my function and it takes just 1.5 second to finish.
I do not know where is the bottleneck on my code and How to optimize it.
There is no problem to totally change my codes or provide a new one. In advance, pleased for all your help.

Option Explicit
Option Compare Text

Function RemoveDuplicateLines(ByVal Text As String, Optional delimiter As String = vbLf) 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
End If
Next

If dictionary.Count > 0 Then
RemoveDuplicateLines = Join(dictionary.keys, delimiter)
Else
RemoveDuplicateLines = ""
End If

Set dictionary = Nothing
End Function

Sub Remove_Duplicate_Lines()
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With

On Error GoTo Errorhandler

Dim ws As Worksheet: Set ws = sh2
Dim crg As Range
Set crg = ws.Range("O2:O" & ws.Cells(Rows.Count, "O").End(xlUp).Row) '#Column contains Combined URL

Dim arr: arr = crg.Value2
Dim i As Long
For i = LBound(arr) To UBound(arr)
arr(i, 1) = RemoveDuplicateLines(arr(i, 1))
Next i
crg.value = arr

Errorhandler:
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

• You should better define « slow », is it 5 sec, 30 sec, 5 mins ? Aug 4 at 6:23

## Binding

Late-binding is slower than early-binding. Add a reference to Microsoft Scripting Runtime:

then change Dim dictionary As Object to Dim dict As Dictionary and Set dictionary = CreateObject("Scripting.Dictionary") to Set dict = New Dictionary. Note that these are not the final declarations but more on this below.

## Declare variables

The line Dim x, part simply declares 2 variables of type Variant by default. Although x needs to be a Variant because it's used in a For Each... loop you should still declare it as a best practice. part however should be declared as String. Never use Variant if you already know the var type because the extra wrapping is using extra resources.

Also, a For... To... loop is slightly faster on a 1D array, compared to a For Each..., so really you don't need x to be Variant at all but rather an iterator declared as Long and an array of String() as that is returned by Split.

## Efficiency

You are presuming that all values in the O column are strings. It's better to only run the RemoveDuplicateLines for strings only and not for anything else like blanks or numbers. So, use VarType to check for type.

If the number of individual lines returned by the call to Split is exactly the same as the number of keys in the dictionary (i.e. no duplicates) then there is no need to join the keys because the original string would already be satisfactory as the result. Same goes for trimming - if trim does not remove any character then we can use the original text as long as there were no duplicates either.

You could avoid a lot of string copying by changing the string by reference and not returning as a result of the function. This improves efficiency a lot.

Using a Static dictionary will remove the need to instantiate a Dictionary on each call.

## Other

You should not restore the state of the application to 'On' as maybe it was intentionally off before running your macro. So, store state, turn things off and finally restore when done.

To make the main method reusable, you should pass the range from a higher level method call so that you can run your macro on other ranges as well.

No need for Option Compare Text as the Dictionary.CompareMode option takes care of text comparison for keys.

## Solution

Run Main method below:

Option Explicit

Public Sub Main()
Dim rng As Range
'
On Error Resume Next
With ActiveSheet 'Or whatever worksheet
Set rng = .Range("O2:O" & .Cells(Rows.Count, "O").End(xlUp).Row) 'Or whatever range
End With
On Error GoTo 0
If rng Is Nothing Then Exit Sub 'Or display a message
'
RemoveDuplicateLinesFromRange rng
End Sub

Public Sub RemoveDuplicateLinesFromRange(ByVal rng As Range _
, Optional ByVal delimiter As String = vbLf)
If rng Is Nothing Then
Err.Raise 91, , "Range not set"
ElseIf rng.Areas.Count > 1 Then
Err.Raise 5, , "Non-contigous range"
End If
'
Dim xlCalc As XlCalculation: xlCalc = Application.Calculation
Dim displayOn As Boolean:    displayOn = Application.ScreenUpdating
Dim eventsOn As Boolean:     eventsOn = Application.EnableEvents
'
With Application
If xlCalc <> xlCalculationManual Then .Calculation = xlCalculationManual
If displayOn Then .ScreenUpdating = False
If eventsOn Then .EnableEvents = False
End With
'
Dim arr() As Variant
Dim i As Long
Dim j As Long
'
If rng.Count = 1 Then
ReDim arr(1 To 1, 1 To 1)
arr(1, 1) = rng.Value2
Else
arr = rng.Value2
End If
'
If UBound(arr, 1) < UBound(arr, 2) Then
For i = LBound(arr, 1) To UBound(arr, 1)
For j = LBound(arr, 2) To UBound(arr, 2)
RemoveDuplicateLines arr(i, j), delimiter
Next j
Next i
Else
For j = LBound(arr, 2) To UBound(arr, 2)
For i = LBound(arr, 1) To UBound(arr, 1)
RemoveDuplicateLines arr(i, j), delimiter
Next i
Next j
End If
rng.Value2 = arr
'
With Application
If xlCalc <> xlCalculationManual Then .Calculation = xlCalc
If displayOn Then .ScreenUpdating = True
If eventsOn Then .EnableEvents = True
End With
End Sub

Private Sub RemoveDuplicateLines(ByRef v As Variant _
, Optional ByVal delimiter As String = vbLf)
If VarType(v) <> vbString Then Exit Sub
'
Static dict As dictionary
Dim parts() As String
Dim i As Long
Dim hasChanged As Boolean
'
If dict Is Nothing Then
Set dict = New dictionary
dict.CompareMode = vbTextCompare
Else
dict.RemoveAll
End If
'
parts = Split(v, delimiter)
If LBound(parts) = UBound(parts) Then
v = Trim$(v) Exit Sub End If ' For i = LBound(parts, 1) To UBound(parts, 1) If TrimIfNeeded(parts(i)) Then hasChanged = True dict(parts(i)) = Empty Next ' If hasChanged Or (UBound(parts, 1) - LBound(parts, 1) + 1 > dict.Count) Then v = Join(dict.Keys, delimiter) End If End Sub Private Function TrimIfNeeded(ByRef Text As String) As Boolean Dim size As Long: size = Len(Text) If size = 0 Then Exit Function ' Text = Trim$(Text)
TrimIfNeeded = (size > Len(Text))
End Function


## Final thoughts

You might want to check for formulas. When you read an entire range, you could have a combination of formulas and values so you might want to update code to exclude formula cells from the macro.

• It works excellently 👍, your code just took 0.4 second to finish, It’s like rocket speed. I will follow your notes and recommendations. Aug 3 at 13:25