Как я могу сделать подпапки подпапок?

Question

У меня есть каталог с тысячами файлов.Строка имени файла выглядит следующим образом: ManagerName_EmployeeName_First Assessment.xlsx

, но у меня есть определенный тип группировки, который мне нужно выполнить, чтобы у меня были папки, идущие по ManagerName> Employee Name, а затем 5 типов оценок впапка сотрудников.

Как мне отредактировать это, чтобы идентифицировать первый _ в имени файла (ManagerName), а затем создать папку с этим ManagerName, а затем создать подпапку с помощью EmployeeName, а затем поместить все пять файлов вэтот сотрудник в подпапке сотрудников?

Я знаю, что вам нужно использовать функцию типа Left(fileName, InStrRev(fileName, "_") > 1), чтобы идентифицировать первую текстовую строку слева от первой _, но как мне пойти и создать вторую подпапку на основе сотрудника вэтот менеджер?

Вот оболочка кода, о котором я думал:

Option Explicit
Sub MoveFiles()

Dim objFSO          As Object
Dim objMyFolder     As Object
Dim objMyFile       As Object
Dim strSourceFolder As String
Dim strDestFolder   As String

Application.ScreenUpdating = False

strSourceFolder = "C:\Users\CIB\"

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objMyFolder = objFSO.GetFolder(strSourceFolder)

For Each objMyFile In objMyFolder.Files

    Do While objMyFile <> ""

        strDestFolder = Left(objMyFile.Name, InStrRev(objMyFile, "_") - 1)
        If Len(Dir(strDestFolder, vbDirectory)) = 0 Then
            MkDir strDestFolder
        End If

        FileCopy strSourceFolder & "\" & objMyFile.Name, strDestFolder & "\" & objMyFile.Name

        Kill strSourceFolder & "\" & objMyFile.Name

    Loop

Next objMyFile

Set objFSO = Nothing
Set objMyFolder = Nothing

Application.ScreenUpdating = True

End Sub

Answer 1

Я изменил ваш код соответственно на TimWiliams предложения:

Option Explicit

Sub MoveFiles()

    Dim objFSO          As Object
    Dim objMyFolder     As Object
    Dim objMyFile       As Object
    Dim strSourceFolder As String
    Dim strDestFolder   As String
    Dim parts() As String
    Dim i As Integer

    Application.ScreenUpdating = False

    strSourceFolder = "C:\Users\CIB\"

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objMyFolder = objFSO.GetFolder(strSourceFolder)

    For Each objMyFile In objMyFolder.Files

        If objMyFile Is Nothing Then GoTo SkipNext

        parts = Split(objMyFile.Name, "_")
        strDestFolder = strSourceFolder
        For i = LBound(parts) To UBound(parts) - 1
            strDestFolder = strDestFolder & parts(i) & "\"
            'if path does not exists, create it
            If Not objFSO.FolderExists(strDestFolder) Then objFSO.CreateFolder strDestFolder

        FileCopy strSourceFolder & "\" & objMyFile.Name, strDestFolder & "\" & objMyFile.Name
        Kill strSourceFolder & "\" & objMyFile.Name
        strDestFolder = ""

        SkipNext:
    Next objMyFile

    Set objFSO = Nothing
    Set objMyFolder = Nothing

    Application.ScreenUpdating = True

End Sub