Anthony's VBA Forum Index Anthony's VBA Forum
Where the knowledge is shared
Menu
 Anthony's VBA Forum IndexHome Page
 Anthony's VBA Forum IndexForum Index
FAQFAQ
MemberlistMemberlist
UsergroupsUsergroups
RegisterRegister
ProfileProfile
Log in to check your private messagesMessages
Log inLogin/Out

Quick Search

Advanced Search

Links
Consulting
Products

Who's Online
[ Administrator ]
[ Moderator ]


VB Macro to find unique entry within a excel column and cell

 
Post new topic   Reply to topic     Anthony's VBA Forum Index -> General Excel VBA
View previous topic :: View next topic  
Author Message
hossain.iqbal



Joined: 22 Feb 2009
Posts: 3

PostPosted: Sun Feb 22, 2009 1:09 am    Post subject: VB Macro to find unique entry within a excel column and cell Reply with quote

Hello,

i have been looking a way to count unique entries using VB script. There are a lot of sample VB script but I have a little twist with my situation. Please see below example.

consider below data to be one column and each new lines as new rows


SDR45322
SDR74564
SDR58493, SDR45322
SDR34534
SDR74564

What I expect my answer to be is: total new SDR count = 4. My life would have been very simple if I didnt have to deal with multiple SDR in one single cell which are separated by comma.

I signed up on this forum with the hope that SOMEONE will be kind / knowledgeable enough to help me out!

Thanks in advance for whoever had a chance to read my question.

Riz
Back to top
View user's profile Send private message
Kenneth Hobson
Gold Member
Gold Member


Joined: 25 Mar 2007
Posts: 21
Location: Tecumseh, OK

PostPosted: Thu Mar 05, 2009 12:06 am    Post subject: Reply with quote

Welcome to the forum!

Put this in a Module and use it as a UDF as shown.
[code]'=UniqueCount(A1:A5)
Function UniqueCount(rToCount As Range, Optional delim As String = ",") As Long
Dim e, r As Range
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For Each r In rToCount
For Each e In Split(r.Text, delim)
If Trim(e) <> "" And Not .Exists(Trim(e)) Then .Add Trim(e), Nothing
Next e
Next r
UniqueCount = .Count
End With
End Function[/code]
Back to top
View user's profile Send private message
Kenneth Hobson
Gold Member
Gold Member


Joined: 25 Mar 2007
Posts: 21
Location: Tecumseh, OK

PostPosted: Thu Mar 05, 2009 12:06 am    Post subject: Reply with quote

Welcome to the forum!

Put this in a Module and use it as a UDF as shown.
[code]'=UniqueCount(A1:A5)
Function UniqueCount(rToCount As Range, Optional delim As String = ",") As Long
Dim e, r As Range
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For Each r In rToCount
For Each e In Split(r.Text, delim)
If Trim(e) <> "" And Not .Exists(Trim(e)) Then .Add Trim(e), Nothing
Next e
Next r
UniqueCount = .Count
End With
End Function[/code]
Back to top
View user's profile Send private message
Kenneth Hobson
Gold Member
Gold Member


Joined: 25 Mar 2007
Posts: 21
Location: Tecumseh, OK

PostPosted: Thu Mar 05, 2009 12:07 am    Post subject: Reply with quote

Welcome to the forum!

Put this in a Module and use it as a UDF as shown.
[code]'=UniqueCount(A1:A5)
Function UniqueCount(rToCount As Range, Optional delim As String = ",") As Long
Dim e, r As Range
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For Each r In rToCount
For Each e In Split(r.Text, delim)
If Trim(e) <> "" And Not .Exists(Trim(e)) Then .Add Trim(e), Nothing
Next e
Next r
UniqueCount = .Count
End With
End Function[/code]
Back to top
View user's profile Send private message
hossain.iqbal



Joined: 22 Feb 2009
Posts: 3

PostPosted: Thu Mar 05, 2009 12:30 am    Post subject: Reply with quote

Hello Kenneth,

Thank you so much for your reply. I couldnt get your code to run for some reason: just to make sure, can you please confirm that the below information is correct?



Sub ed()
[code] '=UniqueCount(A1:A5)
Function UniqueCount(rToCount As Range, Optional delim As String = ",") As Long
Dim e, r As Range
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For Each r In rToCount
For Each e In Split(r.Text, delim)
If Trim(e) <> "" And Not .Exists(Trim(e)) Then .Add Trim(e), Nothing
Next e
Next r
UniqueCount = .Count
End With
End Function[code]
End Function
End Sub
Back to top
View user's profile Send private message
Kenneth Hobson
Gold Member
Gold Member


Joined: 25 Mar 2007
Posts: 21
Location: Tecumseh, OK

PostPosted: Thu Mar 05, 2009 9:09 am    Post subject: Reply with quote

Sorry about the multiple posts. Not sure why the forum did that.

You put a Sub around a Function. They are separate. You can run a Function from a Sub if needed.

To use what I posted. Put your data in cells A1 to A5. In A6, put:
=UniqueCount(A1:A5)

This is called a UDF, user-defined function. They work just like the built-in functions like =Sum().

Unfortunately, this forum does not format text between code tags since HTML is set to off. So, you don't see the structure in macros.

'=UniqueCount(A1:A5)
Function UniqueCount(rToCount As Range, Optional delim As String = ",") As Long
Dim e, r As Range
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For Each r In rToCount
For Each e In Split(r.Text, delim)
If Trim(e) <> "" And Not .Exists(Trim(e)) Then .Add Trim(e), Nothing
Next e
Next r
UniqueCount = .Count
End With
End Function
Back to top
View user's profile Send private message
hossain.iqbal



Joined: 22 Feb 2009
Posts: 3

PostPosted: Thu Mar 05, 2009 10:54 am    Post subject: WoW~!!!!! Reply with quote

THIS ACTUALLYYYYYYYY WORKED!!!!!!!!!

I am really really SURPRISED that it actually WORKED!!

Even though I have nooooooooo idea how it worked!!

You have no idea how greateful I am! Just to prove you, below is the code that I currently have to do pretty much what you do in few lines... i have spent many hours and got that far. Your code would be PERFECT for what I need! I am just showing you my code to just illustrate how much time I had spent!!





Private Sub CommandButton1_Click()

Set Start = Range("A1")
Dim click
Dim i
Dim j
i = 1
click = 0

delete_page
copy_stuff



Do Until click = 5
k = splitCell(i, j)
Remove_Left_empty_Space
Remove_Right_empty_Space
RemoveDuplicates
click = click + 1
Loop

count_new_sdr

End Sub

Function splitCell(ByVal i As Integer, ByVal j As Integer)

Do Until Range("A" & i) = ""
Range("A" & i) = UCase(Range("A" & i)) 'makes everything upper case
j = i + 1
Dim x As Variant

If Range("A" & i).Value <> "" Then
x = Split(Range("A" & i).Value, ",")
If UBound(x) > 0 Then Range("A" & j).Resize(UBound(x)).Insert shift:=xlShiftDown
Range("A" & i).Resize(UBound(x) - LBound(x) + 1).Value = Application.Transpose(x)
i = plusOne(i)
Else
Range("A" & i).Resize(1, 1).Delete shift:=xlShiftUp
End If



Loop
Exit Function

End Function


Function plusOne(ByVal i As Integer) As Integer
plusOne = i + 1
Exit Function
End Function

Sub Remove_Left_empty_Space()
Dim C As Range
For Each C In ActiveSheet.UsedRange
If Left(C.Value, 1) = " " Then C.Value = Right(C.Value, Len(C.Value) - 1)
C.Value = C.Value
Next C
End Sub

Sub Remove_Right_empty_Space()
Dim C As Range
For Each C In ActiveSheet.UsedRange
If Right(C.Value, 1) = " " Then C.Value = Left(C.Value, Len(C.Value) - 1)
C.Value = C.Value
Next C
End Sub


Sub RemoveDuplicates()


Cells.Sort Key1:=Range("A1")
totalrows = ActiveSheet.UsedRange.Rows.count

For Row = totalrows To 2 Step -1
If Cells(Row, 1).Value = Cells(Row - 1, 1).Value Then
Rows(Row).Delete
End If
Next Row



End Sub





Sub copy_stuff()

Dim i
i = 0

Do Until i = 1000
i = i + 1

Range("A" & i) = Sheets("Sheet3").Range("A" & i)


Loop
End Sub



Sub count_new_sdr()

Dim count
Dim i
count = 0
i = 1

Do Until Range("A" & i) = ""
i = i + 1
count = count + 1
Loop


Range("E2") = count

Range("E1") = "Total New SDR Found"

'Sheets("Sheet3").Range("E1") = "Total New SDR Found"

MsgBox "Total new sdr found:" & count

End Sub




Sub delete_page()

Cells.Select
Selection.ClearContents
End Sub
Back to top
View user's profile Send private message
Kenneth Hobson
Gold Member
Gold Member


Joined: 25 Mar 2007
Posts: 21
Location: Tecumseh, OK

PostPosted: Thu Mar 05, 2009 6:03 pm    Post subject: Reply with quote

Good deal. The code works because the Dictionary object does not accept duplicate entries. We can do the same thing using a Collection if the user does not have the MicroSoft Scripting Runtime but most users do.
Back to top
View user's profile Send private message
Display posts from previous:   
Post new topic   Reply to topic     Anthony's VBA Forum Index -> General Excel VBA All times are GMT - 4 Hours
Page 1 of 1

 
Jump to:  
You cannot post new topics in this forum
You cannot reply to topics in this forum
You cannot edit your posts in this forum
You cannot delete your posts in this forum
You cannot vote in polls in this forum


Powered by phpBB © 2001, 2002 phpBB Group