|
View previous topic :: View next topic |
Author |
Message |
hossain.iqbal
Joined: 22 Feb 2009 Posts: 3
|
Posted: Sun Feb 22, 2009 1:09 am Post subject: VB Macro to find unique entry within a excel column and cell |
|
|
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 |
|
|
Kenneth Hobson Gold Member
Joined: 25 Mar 2007 Posts: 21 Location: Tecumseh, OK
|
Posted: Thu Mar 05, 2009 12:06 am Post subject: |
|
|
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 |
|
|
Kenneth Hobson Gold Member
Joined: 25 Mar 2007 Posts: 21 Location: Tecumseh, OK
|
Posted: Thu Mar 05, 2009 12:06 am Post subject: |
|
|
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 |
|
|
Kenneth Hobson Gold Member
Joined: 25 Mar 2007 Posts: 21 Location: Tecumseh, OK
|
Posted: Thu Mar 05, 2009 12:07 am Post subject: |
|
|
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 |
|
|
hossain.iqbal
Joined: 22 Feb 2009 Posts: 3
|
Posted: Thu Mar 05, 2009 12:30 am Post subject: |
|
|
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 |
|
|
Kenneth Hobson Gold Member
Joined: 25 Mar 2007 Posts: 21 Location: Tecumseh, OK
|
Posted: Thu Mar 05, 2009 9:09 am Post subject: |
|
|
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 |
|
|
hossain.iqbal
Joined: 22 Feb 2009 Posts: 3
|
Posted: Thu Mar 05, 2009 10:54 am Post subject: WoW~!!!!! |
|
|
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 |
|
|
Kenneth Hobson Gold Member
Joined: 25 Mar 2007 Posts: 21 Location: Tecumseh, OK
|
Posted: Thu Mar 05, 2009 6:03 pm Post subject: |
|
|
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 |
|
|
|
|
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
|