Checking data in array

[excel.vba]

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

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!

 

[xenou]

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.

[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]

 

[Marcelo Branco]

Hi,

Maybe this

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.

 

[excel.vba]

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.

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

 

[xenou]

Perhaps just:

myCollection.Add Item:=Trim(temp), key:=Trim(temp)