Создать папку и подпапку в Excel VBA

Question

У меня есть файл Excel с сотнями имен клиентов и несколькими номерами статей. Чего я хочу добиться, так это иметь макрос, который проверяет, существует ли папка с выбранным именем клиента, и создает новую папку, если она отсутствует. Как только папка клиента найдена или создана, макрос должен проверить, существует ли папка для каждого номера статьи, и, если она отсутствует, создать новую. Я нашел код, который, кажется, делает все это и многое другое, опубликованный Скоттом Хольцманом, но, поскольку моя репутация слишком низка, чтобы комментировать, я не могу попросить объяснения в этой теме.

Я ссылался на Microsoft Scripting Runtime в качестве запросов кода, но оба оператора «Если нет» помечены красным, а во всплывающем окне отображается только «Ошибка компиляции». Я проверил синтаксис операторов «Если нет», и он кажется правильным, но так как я не имею опыта в VBA, я не могу быть уверен. Есть ли что-то еще, что я должен активировать где-нибудь, чтобы это работало?

'requires reference to Microsoft Scripting Runtime
Sub MakeFolder()

Dim strComp As String, strPart As String, strPath As String

strComp = Range("A1") ' assumes company name in A1
strPart = CleanName(Range("C1")) ' assumes part in C1
strPath = "C:\Images\"

If Not FolderExists(strPath & strComp) Then 
'company doesn't exist, so create full path
    FolderCreate strPath & strComp & "\" & strPart
Else
'company does exist, but does part folder
    If Not FolderExists(strPath & strComp & "\" & strPart) Then
        FolderCreate strPath & strComp & "\" & strPart
    End If
End If

End Sub

Function FolderCreate(ByVal path As String) As Boolean

FolderCreate = True
Dim fso As New FileSystemObject

If Functions.FolderExists(path) Then
    Exit Function
Else
    On Error GoTo DeadInTheWater
    fso.CreateFolder path ' could there be any error with this, like if the path is really screwed up?
    Exit Function
End If

DeadInTheWater:
    MsgBox "A folder could not be created for the following path: " & path & ". Check the path name and try again."
    FolderCreate = False
    Exit Function

End Function

Function FolderExists(ByVal path As String) As Boolean

FolderExists = False
Dim fso As New FileSystemObject

If fso.FolderExists(path) Then FolderExists = True

End Function

Function CleanName(strName as String) as String
'will clean part # name so it can be made into valid folder name
'may need to add more lines to get rid of other characters

    CleanName = Replace(strName, "/","")
    CleanName = Replace(CleanName, "*","")
    etc...

End Function

Answer 1

Если вы хотите сократить количество этого кода, используйте MKDIR для создания каждого уровня папки \ подпапки с ошибкой передачи.

Option Explicit

Sub main()

    Dim pth As String

    pth = "c:\test\abc\123\test_again\XYZ\01-20-2019"

    'folder may or may not exist

    makeFolder pth

    'folder definitely exists

End Sub

Sub makeFolder(fldr As String)

    Dim i As Long, arr As Variant

    'folder may or may not exist

    arr = Split(fldr, Chr(92))
    fldr = arr(LBound(arr))

    On Error Resume Next
    For i = LBound(arr) + 1 To UBound(arr)
        fldr = Join(Array(fldr, arr(i)), Chr(92))
        MkDir fldr
    Next i
    On Error GoTo 0

    'folder definitely exists

End Sub

Answer 2

Взгляните на приведенный ниже пример, он показывает один из возможных подходов с использованием рекурсивного суб-вызова:

Option Explicit

Sub TestArrays()

    Dim aCustomers
    Dim aArticles
    Dim sCustomer
    Dim sArticle
    Dim sPath

    sPath = "C:\Test"
    aCustomers = Array("Customer01", "Customer02", "Customer03", "Customer04", "Customer05")
    aArticles = Array("Article01", "Article02", "Article03", "Article04", "Article05")
    For Each sCustomer In aCustomers
        For Each sArticle In aArticles
            SmartCreateFolder sPath & "\" & sCustomer & "\" & sArticle
        Next
    Next

End Sub

Sub TestFromSheet()

    Dim aCustomers
    Dim aArticles
    Dim i
    Dim j
    Dim sPath

    sPath = "C:\Test"
    With ThisWorkbook.Sheets(1)
        aCustomers = .Range(.Range("A1"), .Range("A1").End(xlDown)).Value
        aArticles = .Range("B1:B10").Value
    End With
    For i = LBound(aCustomers, 1) To UBound(aCustomers, 1)
        For j = LBound(aArticles, 1) To UBound(aArticles, 1)
            SmartCreateFolder sPath & "\" & aCustomers(i, 1) & "\" & aArticles(j, 1)
        Next
    Next

End Sub

Sub SmartCreateFolder(sFolder)

    Static oFSO As Object

    If oFSO Is Nothing Then Set oFSO = CreateObject("Scripting.FileSystemObject")
    With oFSO
        If Not .FolderExists(sFolder) Then
            SmartCreateFolder .GetParentFolderName(sFolder)
            .CreateFolder sFolder
        End If
    End With

End Sub

Sub TestArrays() проверяет и создает папки для клиентов и статей из жестко закодированных массивов, а Sub TestFromSheet() получает клиентов и статьи с первого листа, например, диапазон клиентов от А1 до последнего элемента, так что должно быть больше чем один элемент, и статьи установлены на фиксированный диапазон B1: B10, как показано ниже:

Answer 3

Выпуск StrComp

Вы не можете использовать StrComp , это зарезервированное слово, фактически строковая функция. Я потерял около 15 минут на днях по этому вопросу.

VBA сообщает: возвращает вариант (целое число), указывающий результат сравнения строк.