Checking data in array

excel.vba

New Member
Joined
May 26, 2011
Messages
30
Hello

I am currently working on an excel sheet whereby there is a list of names in 5 columns. Some rows in these columns have more than one name in each cell. These names are separated with a return carriage.

I need to know the number of non repetitive names in these 5 columns.
I was thinking of first separating these names by using text to columns, assigning them to an array and then looping through to check for repetitions, and increasing the count when a name that appears only once in the array is found. If the name is found again it should not count.

I am not sure if my requirements are clear. So far I only have the code to separate the names by text to columns
Code:
Sub CountName()

Dim rngSource As Range
Dim rngDestination As Range

Set rngSource = Sheet1.Range("E2:E5") ' or wherever my list is, working with only one column for now
Set rngDestination = Sheet1.Range("O2") ' parsed data will be placed here

rngSource.TextToColumns _
    Destination:=rngDestination, _
    DataType:=xlDelimited, _
    Other:=True, _
    OtherChar:=vbLf

End Sub

Any help would be greatly appreciated! :)
 

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.
I put sample data (of alphabet letters) in about 10 rows and 5 columns for testing - this seems to work in an ad hoc way (you must have a cell selected in the data range, and it must be a discrete range bounded by empty row(s) and column(s) on every side (since I use current region to detect the range).

Note that I used Alt + Enter to add the "Carriage Returns" but in Excel this inserts a Line Feed. You may need to use vbCrLf, rather than vbLf as I did in this code (in red below).

My intention here was 1) to output the values in a single column (which can then be evaluated with the "remove duplicates" utility of your choice; and 2) to perform output the unique values, for which purpose I ran a second routine to filter it through a vba dictionary - this should be fairly robust into the tens of thousands, though I haven't pushed dictionaries beyond about 30,000 unique values in practical experience (no idea what limitations there are - probably just those of available memory).

Note: my output locations are hard coded in - my data was only in columns A:E. This really should have been out to another sheet so as not to overwrite anything. So beware. This code as written isn't going to care much about what's on the sheet.

Code:
[COLOR="Navy"]Sub[/COLOR] F00()
[COLOR="Navy"]Dim[/COLOR] r [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] a
[COLOR="Navy"]Dim[/COLOR] b()
[COLOR="Navy"]Dim[/COLOR] arrTemp
[COLOR="Navy"]Dim[/COLOR] i [COLOR="Navy"]As[/COLOR] Long, j [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] ii [COLOR="Navy"]As[/COLOR] Long, jj [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]

[COLOR="Navy"]Set[/COLOR] r = ActiveCell.CurrentRegion
a = r.Value
[COLOR="Navy"]ReDim[/COLOR] b(1 [COLOR="Navy"]To[/COLOR] (r.Cells.Count * 3))

[COLOR="Navy"]For[/COLOR] i = 1 [COLOR="Navy"]To[/COLOR] UBound(a, 1)
    [COLOR="Navy"]For[/COLOR] j = 1 [COLOR="Navy"]To[/COLOR] UBound(a, 2)
        arrTemp = Split(r.Cells(i, j).Value, [COLOR="Red"]vbLf[/COLOR])
        [COLOR="Navy"]Debug[/COLOR].[COLOR="Navy"]Print[/COLOR] r.Cells(i, j).Value
        [COLOR="Navy"]For[/COLOR] ii = 0 [COLOR="Navy"]To[/COLOR] UBound(arrTemp)
           jj = jj + 1
           b(jj) = arrTemp(ii)
            [COLOR="Navy"]If[/COLOR] jj = UBound(b) [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]ReDim[/COLOR] [COLOR="Navy"]Preserve[/COLOR] b(1 [COLOR="Navy"]To[/COLOR] UBound(b) + r.Cells.Count)
            [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]If[/COLOR]
        [COLOR="Navy"]Next[/COLOR] ii
    [COLOR="Navy"]Next[/COLOR] j
[COLOR="Navy"]Next[/COLOR] i

[COLOR="Navy"]ReDim[/COLOR] [COLOR="Navy"]Preserve[/COLOR] b(1 [COLOR="Navy"]To[/COLOR] jj)
[COLOR="Red"]
Range("F1")[/COLOR].Resize(UBound(b), 1).Value = Application.WorksheetFunction.Transpose(b)
arrTemp = Get_Uniques(b)
[COLOR="Red"]Range("G1")[/COLOR].Resize(UBound(arrTemp), 1).Value = Application.WorksheetFunction.Transpose(arrTemp)


[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

[COLOR="Navy"]Function[/COLOR] Get_Uniques(ByRef arg() [COLOR="Navy"]As[/COLOR] Variant) [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Variant[/COLOR]
[COLOR="Navy"]Dim[/COLOR] d [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] i [COLOR="Navy"]As[/COLOR] Long, j [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] a

    [COLOR="Navy"]Set[/COLOR] d = CreateObject("Scripting.Dictionary")
    [COLOR="Navy"]For[/COLOR] i = LBound(arg) [COLOR="Navy"]To[/COLOR] UBound(arg)
        [COLOR="Navy"]If[/COLOR] [COLOR="Navy"]Not[/COLOR] d.Exists(CStr(arg(i))) [COLOR="Navy"]Then[/COLOR]
            j = j + 1
            d.Add CStr(arg(i)), j
        [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]If[/COLOR]
    [COLOR="Navy"]Next[/COLOR] i
    
    [COLOR="Navy"]If[/COLOR] j > 1 [COLOR="Navy"]Then[/COLOR]
        Get_Uniques = d.Keys
    [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]If[/COLOR]

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Function[/COLOR]
 
Last edited:
Upvote 0
Hi,

Maybe this

Code:
Sub CountName2()
    Dim rngSource As Range
    Dim rngDestination As Range
    Set rngSource = Sheet1.Range("E2:E5") ' or wherever my list is, working with only one column for now
    rngSource.WrapText = False
    Set rngDestination = Sheet1.Range("O2") ' parsed data will be placed here
    rngSource.TextToColumns Destination:=rngDestination, DataType:=xlDelimited, _
         Space:=True, Other:=False
End Sub

HTH

M.
 
Upvote 0
Thanks alot for all the replies! I found an alternative way which allows me to do what i want. The only problem is that i realised that some names have spaces before them which allows them to pass under the radar and be counted as unique. I used trim to remove these spaces but somehow its not detecting.

Code:
Sub CountName()
Dim mgNames As Variant
With Sheets("Sheet1")

   dataend = Range("a" & Rows.Count).End(xlUp).Row
    mgNames = Range("a1", "IV" & dataend).Value
  
End With
Dim myCollection As New Collection
Dim temp As Variant

On Error Resume Next
For Each temp In mgNames


    WorksheetFunction.Trim (temp)
    
    myCollection.Add Item:=temp, key:=temp
Next temp
On Error GoTo 0

ReDim mgNames(1 To myCollection.Count)
For temp = 1 To myCollection.Count
    mgNames(temp) = myCollection(temp)
    
Next temp
i = 1
For Each col In myCollection

With Sheets("Sheet1")
Sheets("Sheet2").Range("A" & i) = col
i = i + 1
End With
Next col

End Sub
 
Upvote 0
Perhaps just:
Code:
myCollection.Add Item:=Trim(temp), key:=Trim(temp)
 
Upvote 0

Forum statistics

Threads
1,224,502
Messages
6,179,126
Members
452,890
Latest member
Nikhil Ramesh

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top