an01digital
12/18/2006 8:41:00 AM
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