VBA导入多个CSV至同名工作表失败：仅清空数据未复制内容

原代码的核心问题有几个：

1. QueryTables未执行刷新：只创建了查询表但没调用.Refresh方法，根本没触发数据导入
2. 工作表名称匹配错误：打开CSV后ActiveSheet.Name是CSV默认的工作表名（比如Sheet1），不是主工作簿里对应的CSV文件名（不含后缀），导致清空和导入都错了目标表
3. 未指定工作表的操作：Columns.AutoFit没指定主工作簿的目标表，只会对打开的CSV表生效
4. 错误掩盖：On Error Resume Next把找不到工作表等错误都藏起来了，排查困难

修复后的VBA代码 #

Sub ImportCSVs()
' 功能：将同文件夹下的CSV文件数据导入主工作簿同名工作表（覆盖原有数据）
    Dim fPath As String
    Dim fCSV As String
    Dim wbCSV As Workbook
    Dim wbMST As Workbook
    Dim targetSheetName As String
    Dim targetSheet As Worksheet

    Set wbMST = ThisWorkbook
    fPath = wbMST.Path & "\" ' 直接用主工作簿路径，避免ActiveWorkbook可能的混乱
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    fCSV = Dir(fPath & "*.csv")
    Do While Len(fCSV) > 0
        ' 提取CSV对应的工作表名（去掉.csv后缀）
        targetSheetName = Left(fCSV, Len(fCSV) - 4)
        
        ' 检查主工作簿是否存在对应工作表
        On Error Resume Next
        Set targetSheet = wbMST.Sheets(targetSheetName)
        On Error GoTo 0
        
        If Not targetSheet Is Nothing Then
            ' 打开CSV文件
            Set wbCSV = Workbooks.Open(fPath & fCSV)
            ' 清空目标表原有数据
            targetSheet.UsedRange.Clear
            ' 直接复制CSV的全部数据到目标表
            wbCSV.Sheets(1).UsedRange.Copy Destination:=targetSheet.Range("A1")
            ' 自动调整列宽
            targetSheet.Columns.AutoFit
            ' 关闭CSV文件
            wbCSV.Close SaveChanges:=False
        Else
            ' 提示找不到对应工作表
            MsgBox "主工作簿中不存在名为 '" & targetSheetName & "' 的工作表，跳过该CSV文件", vbExclamation
        End If
        
        ' 取下一个CSV文件
        fCSV = Dir
    Loop

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Set wbCSV = Nothing
    Set targetSheet = Nothing
    MsgBox "CSV导入完成"
End Sub

关键修改说明 #

• 直接从CSV文件名提取目标工作表名，确保匹配正确
• 增加工作表存在性检查，避免因表名不匹配导致的错误
• 改用直接复制粘贴的方式导入数据，比QueryTables更直观可靠，避免查询表配置问题
• 所有操作都明确指定目标工作表，彻底规避ActiveSheet带来的上下文混乱
• 移除全局的On Error Resume Next，只在检查工作表时临时用，保留错误提示

内容的提问来源于stack exchange，提问作者Calin Coman-Enescu