在Excel VBA中创建文件夹和子文件夹 [英] Create folder and subfolder in Excel VBA

问题描述

我有一个包含数百个客户名称和几个商品编号的Excel文件. 我要实现的是拥有一个宏，该宏可以检查是否存在具有所选客户名称的文件夹，如果缺少该文件夹，则创建一个新文件夹.一旦找到或创建了客户文件夹，宏应检查每个商品编号是否存在一个文件夹，如果缺少，则创建一个新的文件夹. 我找到了似乎可以完成所有所有工作的代码，但斯科特·霍尔茨曼(Scott Holtzman)则发布了更多代码，但是由于我的声誉太低，无法发表评论，因此我无法在该主题中提出解释.

我已将Microsoft Scripting Runtime引用为代码请求，但是两个"If not"语句均标记为红色，并且弹出窗口仅显示"Compile error".我已经检查了"If not"语句的语法，这似乎是正确的，但是由于我没有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

解决方案

看看下面的示例，它显示了使用递归子调用的一种可能方法:

 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()从第一个工作表中获取客户和商品，例如，客户的范围从A1到最后一个元素，因此应该更多而不是一个元素，并且文章设置为固定范围B1:B10，如下所示:

I have an Excel file with hundreds of Customer names and several article numbers. What I want to achieve is to have a macro that checks if a folder exists with selected customer name and create a new folder if it is missing. Once the customer folder is found or created, macro should check if there is a folder for each article number and if it is missing, create a new one. I found a code that seems to do all that and more posted by Scott Holtzman, but since my reputation is too low to comment, I can't ask explanation in that topic.

I have referenced Microsoft Scripting Runtime as the code requests, but both of the "If not" statements are marked red and the pop-up window only says "Compile error". I have checked the syntax of "If not" statements and it seems to be correct but since I'm not experienced in VBA I can't be certain. Is there something more I should activate somewhere for this to work?

'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

解决方案

Take a look at the below example, it shows one of the possible approaches using recursive sub call:

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() checks and creates folders for customers and articles from the hardcoded arrays, and Sub TestFromSheet() gets customers and articles from the first worksheet, as an example customers range from A1 up to the last element, so it should be more than one element there, and articles set to fixed range B1:B10, like shown below:

这篇关于在Excel VBA中创建文件夹和子文件夹的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！