基于Excel列表批量创建Outlook文件夹及子文件夹

• 现有Excel文件，A列存储C盘下600余个文件夹名称，该列表会随新文件夹创建自动更新，已存在的条目无需重复处理
• 需在Outlook收件箱的「Production」文件夹下，根据Excel A列的名称创建对应文件夹（仅创建不存在的），且每个新创建的Outlook文件夹必须包含统一的子文件夹结构（需替换为你实际需要的子文件夹名称）

Option Explicit

Public Sub MoveSelectedMessages()
    Dim objParentFolder As Outlook.Folder ' 父文件夹
    Dim newFolderName 'As String
    Dim strFilepath
    
    Dim xlApp As Object 'Excel.Application
    Dim xlWkb As Object ' As Workbook
    Dim xlSht As Object ' As Worksheet
    Dim rng As Object 'Range

    Set xlApp = CreateObject("Excel.Application")
    
    strFilepath = xlApp.GetOpenFilename
    If strFilepath = False Then
        xlApp.Quit
        Set xlApp = Nothing
        Exit Sub
    End If
      
    Set xlWkb = xlApp.Workbooks.Open(strFilepath)
    Set xlSht = xlWkb.Worksheets(1)
    Dim iRow As Integer
     
    iRow = 2
    
    ' 选择起始父文件夹
    Set objParentFolder = Application.ActiveExplorer.CurrentFolder
 
    Dim parentname

    While xlSht.Cells(iRow, 1) <> ""
        parentName = xlSht.Cells(iRow, 1)
        newFolderName = xlSht.Cells(iRow, 2)
    
        If parentName = "Inbox" Then
            Set objParentFolder = Session.GetDefaultFolder(olFolderInbox)
        Else
            Set objParentFolder = objParentFolder.Folders(parentName)
        End If
        On Error Resume Next

        Dim objNewFolder As Outlook.Folder
        Set objNewFolder = objParentFolder.Folders(newFolderName)

        If objNewFolder Is Nothing Then
            Set objNewFolder = objParentFolder.Folders.Add(newFolderName)
        End If
    
        iRow = iRow + 1

        ' 设置新文件夹为父文件夹
        ' Set objParentFolder = objNewFolder
    
        Set objNewFolder = Nothing
    Wend
     
    xlWkb.Close
    xlApp.Quit
    Set xlWkb = Nothing
    Set xlApp = Nothing
    Set objParentFolder = Nothing
End Sub

Option Explicit

Public Sub CreateOutlookFoldersFromExcel()
    Dim objProductionFolder As Outlook.Folder ' 目标父文件夹：收件箱下的Production
    Dim strExcelPath As String
    Dim xlApp As Object
    Dim xlWkb As Object
    Dim xlSht As Object
    Dim iRow As Integer
    Dim folderName As String
    Dim objNewFolder As Outlook.Folder
    ' 定义统一子文件夹结构，按需修改
    Dim subFolders As Variant
    subFolders = Array("已处理", "待跟进", "附件存档") ' 替换为你实际需要的子文件夹名称
    
    ' 初始化Excel对象（后台运行不显示界面）
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = False
    
    ' 选择目标Excel文件
    strExcelPath = xlApp.GetOpenFilename("Excel文件 (*.xlsx;*.xls), *.xlsx;*.xls")
    If strExcelPath = False Then
        xlApp.Quit
        Set xlApp = Nothing
        Exit Sub
    End If
    
    ' 打开Excel文件及工作表
    Set xlWkb = xlApp.Workbooks.Open(strExcelPath)
    Set xlSht = xlWkb.Worksheets(1)
    
    ' 定位或创建Outlook收件箱下的Production文件夹
    On Error Resume Next
    Set objProductionFolder = Session.GetDefaultFolder(olFolderInbox).Folders("Production")
    On Error GoTo 0
    If objProductionFolder Is Nothing Then
        MsgBox "Outlook收件箱下未找到Production文件夹，已自动创建", vbInformation
        Set objProductionFolder = Session.GetDefaultFolder(olFolderInbox).Folders.Add("Production")
    End If
    
    ' 遍历Excel A列数据（从第2行开始，假设第1行为表头）
    iRow = 2
    While xlSht.Cells(iRow, 1) <> ""
        folderName = Trim(xlSht.Cells(iRow, 1).Value)
        If folderName <> "" Then
            ' 检查文件夹是否已存在
            On Error Resume Next
            Set objNewFolder = objProductionFolder.Folders(folderName)
            On Error GoTo 0
            
            ' 不存在则创建，并添加统一子文件夹结构
            If objNewFolder Is Nothing Then
                Set objNewFolder = objProductionFolder.Folders.Add(folderName)
                Dim subFolderName As Variant
                For Each subFolderName In subFolders
                    On Error Resume Next
                    objNewFolder.Folders.Add subFolderName
                    On Error GoTo 0
                Next subFolderName
            End If
        End If
        iRow = iRow + 1
        Set objNewFolder = Nothing
    Wend
    
    ' 清理对象并提示完成
    xlWkb.Close SaveChanges:=False
    xlApp.Quit
    Set xlSht = Nothing
    Set xlWkb = Nothing
    Set xlApp = Nothing
    Set objProductionFolder = Nothing
    
    MsgBox "文件夹创建完成", vbInformation
End Sub

• 父文件夹定位：直接获取Outlook收件箱下的「Production」文件夹，若不存在则自动创建
• Excel读取逻辑：后台打开Excel文件，遍历A列从第2行开始的非空单元格（假设第1行是表头）
• 文件夹创建逻辑：仅创建不存在的文件夹，避免重复操作
• 子文件夹结构：通过subFolders数组定义统一子文件夹，遍历数组为每个新文件夹创建子目录，已存在的子文件夹会自动跳过（错误处理忽略重复创建的报错）

内容的提问来源于stack exchange，提问作者Mariec_06