Option Explicit
Private Type FolderInfo
Id As Long
Status As String
FullName As String
End Type
Private Sub GetFolders()
Dim rngFolderIds As Excel.Range
Dim rngFolderId As Excel.Range
Dim udtInfo As FolderInfo
Dim strPath As String
Dim strResult As String
With Worksheets("Tabelle1")
Set rngFolderIds = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
End With
strPath = "C:\Mein Verzeichnis\"
strResult = Dir$(strPath, vbDirectory)
Do While strResult <> ""
If strResult = "." Or strResult = ".." Then
GoTo Continue_Do
End If
If Not TryParseFolderName(strPath & strResult, udtInfo) Then
GoTo Continue_Do
End If
Set rngFolderId = rngFolderIds.Find(udtInfo.Id, , xlValues, xlWhole, xlByColumns, MatchCase:=False)
If rngFolderId Is Nothing Then
GoTo Continue_Do
End If
rngFolderId.Worksheet.Cells(rngFolderId.Row, "E").Value = udtInfo.Status
Continue_Do:
strResult = Dir$()
Loop
End Sub
Private Function TryParseFolderName(Folder As String, ByRef FolderInfo As FolderInfo) As Boolean
Dim fi As FolderInfo
With CreateObject("VBScript.RegExp")
.Global = False
.IgnoreCase = True
.MultiLine = False
.Pattern = "([^\\_]+?(\d+))_+([^\\_]+)_+(.+)"
With .Execute(Folder)
If .Count > 0 Then
fi.Id = CLng(.Item(0).Submatches(1))
fi.Status = .Item(0).Submatches(2)
fi.FullName = .Item(0).Value
FolderInfo = fi
TryParseFolderName = True
End If
End With
End With
End Function