Ersetzt mal TryParseFolderName durch das hier:
die Änderungen zu vorher sind hervorgehoben

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 = Mid$(.Item(0).Value, 13, 1)
        fi.FullName = .Item(0).Value
        FolderInfo = fi
        TryParseFolderName = True
      End If
    End With
  End With
   
End Function

Es würde auch reichen die hervorgehobenen Zeilen zu kopieren.