Excel VBA宏按单元格命名新建文件夹并批量保存Word文档问题

问题根因 #

• 代码中的文件夹路径为硬编码的固定值，未读取Excel指定单元格内容生成动态目标文件夹
• 保存文件时同样硬编码了New customer路径，未关联动态创建的文件夹变量，导致路径与实际新建文件夹不匹配

修正后代码 #

Sub 生成客户文档()
    Dim folderPath As String
    Dim wordapp As Object
    ' 此处将Range("A1")替换为你实际存储文件夹名称的单元格位置
    folderPath = "C:\Users\klebg\OneDrive\Zitekick\Kunder\Byg & Brand\TEST\" & Sheets("Testark").Range("A1").Value
    
    ' 检查文件夹是否存在，不存在则创建
    If Dir(folderPath, vbDirectory) = "" Then
        MkDir folderPath
    Else
        MsgBox "Mappe med samme navn eksisterer allerede"
        ' 如果不需要后续操作可以直接退出：Exit Sub
    End If
    
    ' 创建Word应用对象
    Set wordapp = CreateObject("word.Application")
    wordapp.Visible = True ' 统一设置可见性，不用重复调用
    
    ' 处理第一个文档
    wordapp.Documents.Open "C:\Users\klebg\OneDrive\Zitekick\Kunder\Byg & Brand\TEST\test.docx"
    ' 保存时直接调用folderPath变量，自动匹配新建的文件夹，建议补全docx后缀
    wordapp.ActiveDocument.SaveAs folderPath & "\" & Sheets("Testark").Range("A8").Value & ".docx"
    wordapp.ActiveDocument.Close
    
    ' 处理第二个文档
    wordapp.Documents.Open "C:\Users\klebg\OneDrive\Zitekick\Kunder\Byg & Brand\TEST\test2.docx"
    wordapp.ActiveDocument.SaveAs folderPath & "\" & Sheets("Testark").Range("B8").Value & ".docx"
    wordapp.ActiveDocument.Close
    
    ' 退出Word并释放对象，避免后台残留进程
    wordapp.Quit
    Set wordapp = Nothing
End Sub

注意事项 #

• 请将代码中Sheets("Testark").Range("A1")替换为你实际用来定义文件夹名称的Excel单元格位置
• 代码已补充Word进程退出逻辑，避免打开大量Word后台进程占用资源
• 保存文件名主动补全了.docx后缀，避免生成无后缀的无效文件

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