Excel VBA如何使用文件夹对话框设置路径替代手动输入

修改后完整代码 #

Sub Consolidation_FINAL()
' 建议在模块顶部添加 Option Explicit 开启强制变量声明，减少报错概率
Dim wb As Workbook, ws As Worksheet
Dim fso As Object, fldr As Object, wbFile As Object
Dim y As Long, wsLR As Long, x As Long
Dim folderPicker As FileDialog

Set fso = CreateObject("Scripting.FileSystemObject")
' 替换原手动输入路径逻辑，调用文件夹选择对话框
Set folderPicker = Application.FileDialog(msoFileDialogFolderPicker)
With folderPicker
    .Title = "请选择存放CSV文件的目标文件夹"
    ' 用户点击取消则直接退出程序，避免报错
    If .Show <> -1 Then Exit Sub
    Set fldr = fso.GetFolder(.SelectedItems(1))
End With

y = ThisWorkbook.Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1

For Each wbFile In fldr.Files
    If fso.GetExtensionName(wbFile.Name) = "csv" Then
        Set wb = Workbooks.Open(wbFile.Path)
        
        Range("A1").Select
        Selection.End(xlToRight).Offset(RowOffSet:=0, ColumnOffset:=1).Select
        ActiveCell.FormulaR1C1 = ActiveWorkbook.Name
        
        Range("A1").Select
        Selection.End(xlDown).Offset(RowOffSet:=1, ColumnOffset:=0).Select
        ActiveCell.FormulaR1C1 = "-"
        
        For Each ws In wb.Sheets
            wsLR = ws.Cells(Rows.Count, 1).End(xlUp).Row
            For x = 1 To wsLR
              ThisWorkbook.Sheets("sheet1").Cells(y, 1) = ws.Cells(x, 1) 'col 1
              ThisWorkbook.Sheets("sheet1").Cells(y, 2) = ws.Cells(x, 2) 'col 2
              ThisWorkbook.Sheets("sheet1").Cells(y, 3) = ws.Cells(x, 3) 'col 3
              y = y + 1
            Next x
        Next ws
        
        wb.Close SaveChanges:=False
        ' 此处实现粘贴后留空白间隔，如需多空几行修改+后的数值即可
        y = y + 1
    End If
Next wbFile

End Sub

核心改动说明 #

• 替换了原手动输入路径的逻辑：调用系统自带的文件夹选择对话框，选择对应文件夹即可自动获取路径，新增取消操作判断，避免用户点取消后程序报错。
• 新增粘贴后留空白的逻辑：每处理完一个CSV文件后，将行号计数y加1，下一个文件的内容会空出一行再开始粘贴，如需留更多空白行，直接修改y = y + 1里的数值即可，比如填2就是空2行。
• 补充了所有变量的声明，避免未定义变量导致的运行报错。

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