Option Explicit
Public Sub OrderAuflisten()
Dim rngAnchor As Excel.Range
Dim vntFolders As Variant
Dim vntFolder As Variant
Range("A1").Value = "Verzeichnis"
Range("A1").Font.Bold = True
Set rngAnchor = Range("A2")
vntFolders = GetFolders("X:\Scripts")
If UBound(vntFolders) <= 0 Then
Call MsgBox("Keine Verzeichnisse gefunden.", vbExclamation)
Exit Sub
End If
rngAnchor.Resize(RowSize:=UBound(vntFolders) + 1).Value = WorksheetFunction.Transpose(vntFolders)
Dim strFilename As String
Dim iFolder As Long
Dim nValid As Long
For Each vntFolder In vntFolders
nValid = 0
If ValidateFileName("*scan_v2.ps1", CStr(vntFolder), strFilename) Then
Debug.Print ">> '"; strFilename; "'" & "in "; vntFolder
rngAnchor.Offset(iFolder, 1).Interior.Color = rgbGreen
nValid = nValid + 1
End If
If nValid = 4 Then
End If
iFolder = iFolder + 1
Next
Call MsgBox("Vorgang abgeschlossen.", vbInformation)
End Sub
Public Function GetFolders(Folder As String) As Variant
Dim strRoot As String
If Right$(Folder, 1) <> "\" Then
strRoot = Folder & "\"
Else
strRoot = Folder
End If
Dim strFolder As String
ReDim vntFolders(0 To 9) As Variant
Dim i As Long
strFolder = Dir$(strRoot, vbDirectory)
Do Until strFolder = ""
If strFolder = "." Or strFolder = ".." Then
GoTo continue_do
End If
If (GetAttr(strRoot & strFolder) And vbDirectory) <> vbDirectory Then
GoTo continue_do
End If
If i > UBound(vntFolders) Then
ReDim Preserve vntFolders(0 To UBound(vntFolders) * 2.5)
End If
vntFolders(i) = strRoot & strFolder
i = i + 1
continue_do:
strFolder = Dir$(, vbDirectory)
Loop
If i > 0 Then
ReDim Preserve vntFolders(0 To i - 1)
GetFolders = vntFolders
Exit Function
End If
GetFolders = Split(Empty)
End Function
Public Function ValidateFileName(Pattern As String, Folder As String, Optional Filename As String) As Boolean
Dim strFolder As String
Dim strFilename As String
If Right$(Folder, 1) <> "\" Then
strFolder = Folder & "\"
Else
strFolder = Folder
End If
strFilename = Dir$(strFolder & Pattern)
If strFilename = "" Then
Exit Function
End If
Filename = strFilename
ValidateFileName = True
End Function