Excel VBA代码修改：将固定路径遍历改为手动选择文件夹

嘿，我帮你调整了原来的VBA代码，把固定路径的逻辑改成了手动选择文件夹的交互式功能，同时完全保留了你原本的遍历Excel文件、复制指定列到目标文件的核心逻辑。

关键修改点： #

• 移除了硬编码的Const FOLDER_PATH常量，改用字符串变量动态存储用户选择的路径
• 加入了Excel内置的FileDialog(msoFileDialogFolderPicker)对话框，让用户可视化选择目标文件夹
• 增加了用户取消选择时的退出判断，避免报错

修改后的完整代码： #

Option Explicit

Sub ImportIncidentWorksheets()
    Dim sFile As String
    Dim wsTarget As Worksheet
    Dim wbSource As Workbook
    Dim wsSource As Worksheet
    Dim rowTarget As Long
    Dim rowSource As Long
    Dim folderPath As String ' 替换原常量为变量
    
    ' 初始化目标行
    rowTarget = 2
    
    ' 弹出文件夹选择对话框
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "请选择要遍历的Excel文件夹"
        If .Show = -1 Then ' 用户点击了确定
            folderPath = .SelectedItems(1) & "\" ' 确保路径末尾带反斜杠
        Else ' 用户取消选择
            MsgBox "未选择任何文件夹，程序退出！", vbExclamation
            Exit Sub
        End With
    End With
    
    ' 检查选择的文件夹是否存在（保留原有的校验逻辑）
    If Not FileFolderExists(folderPath) Then
        MsgBox "指定的文件夹不存在，程序退出！", vbCritical
        Exit Sub
    End If
    
    ' 初始化目标工作表（请替换成你的目标表名称）
    Set wsTarget = ThisWorkbook.Worksheets("目标工作表")
    wsTarget.Cells.Clear ' 可选：清空目标表原有内容
    
    ' 遍历文件夹下所有Excel文件
    sFile = Dir(folderPath & "*.xlsx") ' 可根据需要改成*.xls或*.xlsm
    Do While sFile <> ""
        Set wbSource = Workbooks.Open(folderPath & sFile, ReadOnly:=True)
        Set wsSource = wbSource.Worksheets(1) ' 假设取第一个工作表，可按需修改
        
        ' ----------------------
        ' 这里是你原有的复制列逻辑，示例：复制A列和C列到目标表
        rowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
        wsSource.Range("A2:A" & rowSource).Copy wsTarget.Range("A" & rowTarget)
        wsSource.Range("C2:C" & rowSource).Copy wsTarget.Range("B" & rowTarget)
        rowTarget = rowTarget + rowSource - 1 ' 更新目标行位置
        ' ----------------------
        
        wbSource.Close SaveChanges:=False ' 关闭源文件不保存
        sFile = Dir ' 获取下一个文件
    Loop
    
    MsgBox "数据导入完成！", vbInformation
End Sub

' 保留原有的文件夹存在性检查函数
Function FileFolderExists(strPath As String) As Boolean
    If Not Dir(strPath, vbDirectory) = "" Then FileFolderExists = True
End Function

注意事项： #

• 请把代码里的"目标工作表"替换成你实际要存放数据的工作表名称
• 如果需要遍历其他格式的Excel文件，把Dir(folderPath & "*.xlsx")改成*.xls或*.xlsm即可
• 复制列的逻辑部分，你可以根据自己的需求调整要复制的列范围和目标位置

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