Removes the Duplicate in a single Cell

[lancerj017]

hi i have a question for you guys is it possible to remove duplicates the data in a single cell using macro?

Example

Column A
with apple, with banana, with apple, with banana
with apple, with apple, with apple
with banana, with banana, with banana

Need to do:

Column A
with apple, with banana
with apple
with banana

that's data is example only!

 

[lancerj017]

Thanks hiker95, I copy your macro and run it. well if you ask me if working... yes its works perfectly. i try to run it with 300k rows then i put application.statusbar to see if the code is still running.. any suggestion to make it fast? i have a idea if the macro ignore the blank cell maybe its making fast a little bit? am i correct?? oh sorry for asking too much... I'm a beginner in VB so that im seeking for help of pro like you :D btw this is the statusbar i put in your code

Option Explicit
Sub RemoveDupesV2()
' hiker95, 02/24/2012
' http://www.mrexcel.com/forum/showthread.php?t=615831
Dim rng As Range, c As Range, Sp, s As Long, v, h As String, x As Double
Application.ScreenUpdating = False

Set rng = Range("A1:E340776")

For Each c In rng
  With CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
    If Trim(c) <> "" Or InStr(Trim(c), ", ") > 0 Then
      h = ""
      Sp = Split(Trim(c), ", ")
      For s = LBound(Sp) To UBound(Sp)
        If Not .Exists(Sp(s)) Then
          .Add Sp(s), Sp(s)
        End If
      Next s
      v = Application.Transpose(Array(.Keys))
      If UBound(v) > 1 Then
        For s = LBound(v) To UBound(v)
          h = h & v(s, 1) & ", "
        Next s
        If Right(h, 2) = ", " Then h = Left(h, Len(h) - 2)
        c = h
      Else
        c = v
      End If
      Erase v
      Erase Sp
    End If
  End With
  
  x = x + 1
  Application.StatusBar = "Please wait while performing task: " & x & " Counts"
  
Next
Application.ScreenUpdating = True
End Sub

 

[hiker95]

lancerj017,

i have a idea if the macro ignore the blank cell maybe its making fast a little bit?

The code for RemoveDupesV2, and RemoveDupesV3, ignores blank cells.


I duplicated Reply #9's raw data down to row 104,000 (range A1:E104000).

Macro RemoveDupesV2 took 175 seconds.

Macro RemoveDupesV3 took 143 seconds utilizing an array in memory.


Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Option Explicit
Sub RemoveDupesV3()
' hiker95, 02/25/2012
' http://www.mrexcel.com/forum/showthread.php?t=615831
Dim r As Long, c As Long, lr As Long, lc As Long
Dim ae() As Variant
Dim Sp, s As Long, v, h As String
Application.ScreenUpdating = False
lr = Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
lc = Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
ae = Range("A1").Resize(lr, lc)
For r = LBound(ae, 1) To UBound(ae, 1)
  For c = LBound(ae, 2) To UBound(ae, 2)
    With CreateObject("scripting.dictionary")
      .CompareMode = vbTextCompare
      If Trim(ae(r, c)) <> "" Or InStr(Trim(ae(r, c)), ", ") > 0 Then
        h = ""
        Sp = Split(Trim(ae(r, c)), ", ")
        For s = LBound(Sp) To UBound(Sp)
          If Not .Exists(Sp(s)) Then
            .Add Sp(s), Sp(s)
          End If
        Next s
        v = Application.Transpose(Array(.Keys))
        If UBound(v) > 1 Then
          For s = LBound(v) To UBound(v)
            h = h & v(s, 1) & ", "
          Next s
          If Right(h, 2) = ", " Then h = Left(h, Len(h) - 2)
          ae(r, c) = h
        Else
          ae(r, c) = v(1)
        End If
        Erase v
        Erase Sp
      End If
    End With
  Next c
Next r
Application.ScreenUpdating = True
Range("A1").Resize(UBound(ae, 1), UBound(ae, 2)) = ae
End Sub

Then run the RemoveDupesV3 macro.

 

[mirabeau]

Would this one be of any interest?

Sub qwerty()
Dim t: t = Timer
Dim d As Object
Dim ss As String, u As String
Dim c As Variant, e As Variant
Dim i As Long, j As Long
Set d = CreateObject("scripting.dictionary")
ss = ", "
rws = Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
cls = Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
With Range("A1").Resize(rws, cls)
    c = .Value
     For i = 1 To rws
           For j = 1 To cls
                u = vbNullString
                For Each e In Split(c(i, j), ss)
                    d(Trim(e)) = 0
                Next e
                For Each e In d.Keys
                    u = u & ss & e
                Next e
            c(i, j) = Replace(u, ss, vbNullString, 1, 1, 1)
            d.RemoveAll
            Next j
        Next i
    .ClearContents
    .Value = c
End With
Debug.Print Timer - t
End Sub

 

[hiker95]

mirabeau,


WOW.... 8.3 seconds


That was amazing, and one for the archives, and testing, to understand just how the code works.

I have been learning how to use arrays in memory, and, again, this was amazing.

Can you suggest any books, web sites, for learing how to use arrays?


Just a few additions to your original code:

Sub qwerty()
' mirabeau, 02/25/2012
' http://www.mrexcel.com/forum/showthread.php?t=615831
Dim t: t = Timer
Dim d As Object
Dim ss As String, u As String
Dim c As Variant, e As Variant
Dim i As Long, j As Long

Dim rws As Long, cls As Long

Set d = CreateObject("scripting.dictionary")
ss = ", "
rws = Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
cls = Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
With Range("A1").Resize(rws, cls)
    c = .Value
     For i = 1 To rws
           For j = 1 To cls
                u = vbNullString
                For Each e In Split(c(i, j), ss)
                    d(Trim(e)) = 0
                Next e
                For Each e In d.Keys
                    u = u & ss & e
                Next e
            c(i, j) = Replace(u, ss, vbNullString, 1, 1, 1)
            d.RemoveAll
            Next j
        Next i
    .ClearContents
    .Value = c
End With

'Debug.Print Timer - t
MsgBox "Total time = " & Timer - t

End Sub

Thanks again, and again, .....


BTW, I have used your web site for the great code with instructions/explainations, and have sent many links to OPs .

 

[mirabeau]

mirabeau,

I have been learning how to use arrays in memory, and, again, this was amazing.

Can you suggest any books, web sites, for learing how to use arrays?

....
....

BTW, I have used your web site for the great code with instructions/explainations, and have sent many links to OPs .

Thanks for your kind comments. I was rather inclined not to post that code at all, since you seemed to be doing OK.

I've never read a book on VBA or on Excel. My background such as it is on arrays etc is mathematical and statistical. A couple of books I used were Alexander Aitken's "Determinants and Matrices" and Richard Bellmans' "Introduction to Matrix Analysis". The notation I use in posted codes very often reflects that of these books rather than that of, I think, any VBA books.

On your BTW, you must have the wrong person. I don't have a website of any kind and have virtually only ever posted codes on this particular forum, coz it seems a lively and active one, good discussion always available, and some of the problems posted can be rather interesting.

 

[lancerj017]

Hi hiker and mirabeau thanks for all of your help... i have another question but i think i need to create another thread hehehe thank you again...

 

[lancerj017]

mirabeau your program is quite good but i discover something when the data is not the same like "with Apple, with apple" your program not remove it... try to run some test... :D

 

[mirabeau]

mirabeau your program is quite good but i discover something when the data is not the same like "with Apple, with apple" your program not remove it... try to run some test... :D

Include another line in the vba code.

...
Set d = CreateObject("scripting.dictionary")
d.comparemode = vbTextCompare
ss = ", "
...

 

[Biz]

mirabeau,


WOW.... 8.3 seconds


That was amazing, and one for the archives, and testing, to understand just how the code works.

I have been learning how to use arrays in memory, and, again, this was amazing.

Can you suggest any books, web sites, for learing how to use arrays?


Just a few additions to your original code:

Sub qwerty()
' mirabeau, 02/25/2012
' http://www.mrexcel.com/forum/showthread.php?t=615831
Dim t: t = Timer
Dim d As Object
Dim ss As String, u As String
Dim c As Variant, e As Variant
Dim i As Long, j As Long
 
Dim rws As Long, cls As Long
 
Set d = CreateObject("scripting.dictionary")
ss = ", "
rws = Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
cls = Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
With Range("A1").Resize(rws, cls)
    c = .Value
     For i = 1 To rws
           For j = 1 To cls
                u = vbNullString
                For Each e In Split(c(i, j), ss)
                    d(Trim(e)) = 0
                Next e
                For Each e In d.Keys
                    u = u & ss & e
                Next e
            c(i, j) = Replace(u, ss, vbNullString, 1, 1, 1)
            d.RemoveAll
            Next j
        Next i
    .ClearContents
    .Value = c
End With
 
'Debug.Print Timer - t
MsgBox "Total time = " & Timer - t
 
End Sub

Thanks again, and again, .....


BTW, I have used your web site for the great code with instructions/explainations, and have sent many links to OPs .

M8 nice code can you pls paste links so we can learn too.
Amazing speed...need for speed lol

Biz

 

[mirabeau]

Lancer, Hiker95, Biz,

Maybe this one is somewhat shorter, faster, and doesn't use esoteric devices like scripting dictionary.

Sub asdfgh()
Dim t As Single: t = Timer
Dim c(), a, x, y
Dim rws As Long, i As Long, j As Long
rws = Range("A" & Rows.Count).End(xlUp).Row
ReDim c(1 To rws, 1 To 1)

For i = 1 To rws
a = Cells(i, 1) & ","

For j = 1 To Len(a)
    x = Trim(Left(a, j))
    y = Trim(Mid(a, j + 1, j))
    If x = y Then Exit For
Next j

c(i, 1) = Left(x, Len(x) - 1)
Next i

Range("B1").Resize(rws) = c
MsgBox Timer - t
End Sub