导入文本文件时出现Querytables错误1004的技术求助

问题背景 #

用VBA从指定目录读取文本文件并生成图表，正常运行无异常，但偶尔突发错误1004，提示文件不存在或被其他程序占用，故障持续一段时间后会自行恢复。已将文件从服务器复制到本地路径，问题仍未解决。

相关代码片段 #

目录常量定义 #

Public Const symosDir As String = "C:\\Users\cdenis\Desktop\Mettre sur réseau\Bibliothèque amortisseurs WinSymos(08-02-23)\"
Public Const d_symosDir As String = symosDir & "fdyn\"
Public Const a_symosDir As String = symosDir & "fam\"
Public Const s_symosDir As String = symosDir & "fstat\"

qPath构造逻辑 #

Dim i As Long
For i = 1 To 4 '遍历d轴，fdyn文件夹
    axe = "d" & i
    qPath = "TEXT;" & d_symosDir & nom & axe & ".bl"
    query ws, rng, nom, axe, qPath, cht
Next i

完整qPath示例 #

TEXT;C:\\Users\cdenis\Desktop\Mettre sur réseau\Bibliothèque amortisseurs WinSymos(08-02-23)\fdyn\CB1700-20d1.bl

查询创建过程 #

Sub query(ws, rng, nom, axe, qPath, cht)
Dim qt

rng.Value = nom '在表头写入减震器名称
rng.Offset(0, 1).Value = axe '在名称右侧列写入轴名称

'On Error Resume Next

'打开qPath路径下的文本文件并粘贴到轴名称下方一行
Set qt = ws.QueryTables.Add(Connection:=qPath, Destination:=rng.Offset(1, 0))

With qt
    .RefreshOnFileOpen = False '禁用打开文件时刷新
    .RefreshStyle = xlOverwriteCells '覆盖单元格
    .AdjustColumnWidth = False '保持原始列宽
    .TextFileStartRow = 3 '从第3行开始复制
    .TextFilePromptOnRefresh = False '禁用刷新提示
    .TextFileParseType = xlDelimited '按分隔符解析文本
    .TextFileTextQualifier = xlTextQualifierNone '不使用文本限定符
    .TextFileCommaDelimiter = True '使用逗号作为分隔符
    .TextFileColumnDataTypes = Array(1, 1) '将数据复制到1列1行的数组中
    .TextFileTrailingMinusNumbers = True '将开头带"-"的数字视为负数
    .Refresh BackgroundQuery:=False '禁用后台刷新
End With

qt.Delete '删除查询

If Err.Number <> 0 Then '若路径或名称无效报错
    Err.Clear
    MsgBox "减震器名称" & nom & "、轴" & axe & "或以下路径无效。" & vbNewLine & _
           qPath
    Exit Sub '退出过程
End If
On Error GoTo 0 '重置错误处理

CreerGraph ws, cht, axe, rng '创建图表/添加数据系列

Set rng = rng.End(xlUp).Offset(0, 2) '向右跳转两列
End Sub

问题分析与解决方案 #

核心原因 #

1. 错误处理逻辑倒置：原代码把错误判断放在qt.Delete之后，且注释了On Error Resume Next，无法捕获Refresh过程中的异常。
2. 资源未及时释放：若Refresh过程出错，qt对象可能未被正确清理，导致后续操作出现资源占用冲突。
3. 路径解析偶发问题：路径包含空格和特殊字符（括号），可能导致QueryTables解析路径时出现不稳定情况。

修改后的代码 #

Sub query(ws As Worksheet, rng As Range, nom As String, axe As String, qPath As String, cht As Chart)
    Dim qt As QueryTable
    Dim filePath As String
    
    ' 提取纯文件路径，提前验证文件是否存在
    filePath = Mid(qPath, 6)
    If Dir(filePath) = "" Then
        MsgBox "减震器名称" & nom & "、轴" & axe & "对应的文件不存在：" & vbNewLine & filePath
        Exit Sub
    End If
    
    rng.Value = nom
    rng.Offset(0, 1).Value = axe
    
    On Error Resume Next
    Set qt = ws.QueryTables.Add(Connection:=qPath, Destination:=rng.Offset(1, 0))
    If Err.Number <> 0 Then
        Err.Clear
        MsgBox "创建查询失败，文件可能被占用：" & vbNewLine & filePath
        On Error GoTo 0
        Exit Sub
    End If
    
    With qt
        .RefreshOnFileOpen = False
        .RefreshStyle = xlOverwriteCells
        .AdjustColumnWidth = False
        .TextFileStartRow = 3
        .TextFilePromptOnRefresh = False
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierNone
        .TextFileCommaDelimiter = True
        .TextFileColumnDataTypes = Array(1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
        
        ' 捕获Refresh过程中的错误
        If Err.Number <> 0 Then
            Err.Clear
            qt.Delete
            MsgBox "读取文件失败，文件可能被占用：" & vbNewLine & filePath
            On Error GoTo 0
            Exit Sub
        End If
    End With
    
    qt.Delete
    On Error GoTo 0
    
    CreerGraph ws, cht, axe, rng
    Set rng = rng.End(xlUp).Offset(0, 2)
End Sub

额外优化建议 #

1. 添加重试机制：针对偶发的文件占用问题，可在Refresh环节增加重试逻辑：

' 在qt.Refresh前插入以下代码
Dim retryCount As Integer
retryCount = 3
Do While retryCount > 0
    qt.Refresh BackgroundQuery:=False
    If Err.Number = 0 Then Exit Do
    Err.Clear
    retryCount = retryCount - 1
    Application.Wait Now + TimeValue("00:00:01") ' 等待1秒后重试
Loop
If retryCount = 0 Then
    MsgBox "多次尝试后仍无法读取文件：" & filePath
    qt.Delete
    Exit Sub
End If

2. 替换为FileSystemObject读取：若问题仍频繁出现，可绕过QueryTables，直接用FileSystemObject读取文本文件：

Dim fso As Object
Dim ts As Object
Dim line As String
Dim rowNum As Integer
rowNum = rng.Offset(1, 0).Row

Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.OpenTextFile(filePath, 1)

' 跳过前2行
ts.SkipLine
ts.SkipLine

Do Until ts.AtEndOfStream
    line = ts.ReadLine
    ws.Cells(rowNum, rng.Column).Value = Split(line, ",")(0)
    ws.Cells(rowNum, rng.Column + 1).Value = Split(line, ",")(1)
    rowNum = rowNum + 1
Loop
ts.Close
Set ts = Nothing
Set fso = Nothing

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