Unique
 

Sub GetNamesinArray()

Dim B()
Dim ListOfNames() As String

Dim FS As FileSearch

Set FS = Application.FileSearch

FS.FileType = msoFileTypeExcelWorkbooks
FS.LookIn = Range("A1").Value
FS.SearchSubFolders = True
FS.Execute

For i = 1 To FS.FoundFiles.Count
ReDim Preserve ListOfNames(1 To i)

If Right(FS.FoundFiles(i), 3) = "xls" Then
Fname1 = Split(FS.FoundFiles(i), "_")
Fname2 = Fname1(UBound(Fname1))

Fname = Mid(Fname2, 1, Len(Fname2) - 4)
Else
Fname = Fname2
End If

ListOfNames(i) = Fname
Next i

B() = UniqueItems(ListOfNames, False)

For i = 1 To UBound(B)
Cells(i + 1, 1).Value = B(i)
Next i

End Sub

Function UniqueItems(ArrayIn, Optional Count As Variant) As Variant
' Accepts an array or range as input
' If Count = True or is missing, the function returns the number
' of unique elements
' If Count = False, the function returns a variant array of unique
' elements


Dim Unique() As Variant ' array that holds the unique items
Dim Element As Variant
Dim i As Integer
Dim FoundMatch As Boolean


' If 2nd argument is missing, assign default value
If IsMissing(Count) Then Count = True


' Counter for number of unique elements
NumUnique = 0


' Loop thru the input array
For Each Element In ArrayIn
FoundMatch = False


' Has item been added yet?
For i = 1 To NumUnique
If Element = Unique(i) Then
FoundMatch = True
GoTo AddItem '(Exit For-Next loop)
End If
Next i


AddItem:
' If not in list, add the item to unique list
If Not FoundMatch Then
NumUnique = NumUnique + 1
ReDim Preserve Unique(NumUnique)
Unique(NumUnique) = Element
End If


Next Element


' Assign a value to the function
If Count Then UniqueItems = NumUnique Else UniqueItems = Unique
End Function