mal ne Liste
06.08.2010 14:27:46
Rudi
Hallo,
damit wird eine Liste aller Files mit dem Wert aus A1 generiert. Kannst du dann ja filtern.
Sub tt()
Dim myFileArray As Variant, lngFileCount As Long
lngFileCount = FileSearchFSO(myFileArray, "c:\test", "*.xls", True)
If lngFileCount > 0 Then
myFileArray = WorksheetFunction.Transpose(myFileArray)
With Worksheets.Add
.Cells(1, 1) = "File"
.Cells(1, 2) = "A1"
.Cells(2, 1).Resize(lngFileCount, 2) = myFileArray
End With
End If
End Sub
Private Function FileSearchFSO _
(ByRef strFiles As Variant, _
ByVal InitialPath As String, _
Optional ByVal FileName As String = "*", _
Optional ByVal SubFolders As Boolean = False) _
As Long
Dim mobjFSO As Object, mfsoFolder As Object, mfsoSubFolder As Object, mfsoFile As Object
Static n As Integer
Set mobjFSO = CreateObject("Scripting.FileSystemObject")
Set mfsoFolder = mobjFSO.GetFolder(InitialPath)
On Error Resume Next
For Each mfsoFile In mfsoFolder.Files
If Not mfsoFile Is Nothing Then
If LCase(mobjFSO.GetFileName(mfsoFile)) Like LCase(FileName) Then
If IsArray(strFiles) Then
n = n + 1
ReDim Preserve strFiles(1 To 2, 1 To n)
Else
n = n + 1
ReDim strFiles(1 To 2, 1 To n)
End If
strFiles(1, n) = mfsoFile
strFiles(2, n) = "='" & mfsoFolder & "\[" & mfsoFile.Name & "]Tabelle1'!A1"
End If
End If
Next
If SubFolders Then
For Each mfsoSubFolder In mfsoFolder.SubFolders
FileSearchFSO strFiles, mfsoSubFolder, FileName, SubFolders
Next
End If
If IsArray(strFiles) Then FileSearchFSO = n
On Error GoTo 0
Set mobjFSO = Nothing
Set mfsoFolder = Nothing
End Function
Gruß
Rudi