Excel VBA读取TSV文本流仅首组单元格写入成功 剩余22组无响应

故障现象 #

• 从TSV文件读取数据填充工作表单元格，开启VBA「遇到所有错误即中断」选项后代码运行全程无弹窗报错
• 经排查，TextStream读取生成的数组数据完整，条件判断保护子句逻辑、列偏移变量i的递增规则、偏移后目标单元格地址均验证无误
• 目标单元格未锁定、工作表未开启保护，已尝试调用.Range("A1")、.MergedArea属性适配合并单元格，运行环境为Office 365专业版
• 实际运行仅第一组数值、文本、日期可正常写入，剩余22组数据完全无法写入

原问题代码如下：

Sub chartTextData(ByVal pathToData As String, dateEarliest As Date, Optional ByVal strFile As String)
    
    On Error GoTo LoopExit
                            Debug.Print Now() & " chartTextData BEGIN"
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    Dim fso As FileSystemObject
    Set fso = New FileSystemObject
    Dim TxtStream As textStream
    Dim linebuffer
    Dim myArray
    Dim cellAnchor As Range
    Dim i As Long
    Debug.Assert i = 0

    Set cellAnchor = ActiveSheet.Range("D39")   '38 on some
    
         Set TxtStream = fso.OpenTextFile(pathToData & strFile, ForReading, False, TristateUseDefault)
Do While Not TxtStream.AtEndOfStream

    linebuffer = TxtStream.ReadLine
    '  0     1     2        3            4        5   6 7
    '33.19,$F$38,good,No Need to Act,11/20/2014,2100,DB,2
    myArray = Split(linebuffer, vbTab, , vbTextCompare)
    'header row, skip it
    If myArray(1) Like "*DATE*" Then GoTo JumpHereToBypassOlderThanDateEarliest
    If myArray(1) < dateEarliest Then GoTo JumpHereToBypassOlderThanDateEarliest

    'Set cellAnchor = ActiveSheet.Range(myArray(1))  'eg, "$D$39"
    cellAnchor.Offset(0, i).Value2 = CDbl(myArray(0))  'test value
    cellAnchor.Offset(3, i).Value2 = CDate(myArray(1))  'Date
    cellAnchor.Offset(2, i).Value2 = myArray(2)  'time
    cellAnchor.Offset(4, i).Value2 = myArray(3)  'Tech
                                'Debug.Print myArray(0)
    i = i + 2                   'merged cells, 2 per
                                'Debug.Print i & " <--i"
    If i >= 46 Then GoTo LoopExit
                                    
JumpHereToBypassOlderThanDateEarliest:
Loop
    
LoopExit:
    TxtStream.Close
    Set TxtStream = Nothing
    Set fso = Nothing
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.Calculate
            Debug.Print Now() & " chartTextData END"
End Sub

根因定位 #

核心问题是代码开头的On Error GoTo LoopExit全局错误捕获直接吞掉了循环内所有运行时错误：只要任意一行数据处理触发异常，代码会立刻跳转到退出收尾逻辑，不再处理后续行。多数用户会混淆VBA IDE的错误中断选项，如果实际设置为遇到未处理的错误时中断，异常会被On Error直接捕获跳过，不会弹出任何报错提示，表现为仅第一组合法数据写入成功，后续流程直接终止。

高频触发异常的场景包括：

• TSV中存在空行、缺字段的格式异常行，Split返回的数组下标不足，访问myArray(1)/myArray(3)等索引时触发下标越界
• TSV中存储的日期/数值字符串和系统区域格式不匹配，CDate()/CDbl()类型转换失败
• 列偏移后的目标单元格落在合并单元格的非左上角区域，Office 365部分版本对此场景不会抛出错误，仅静默丢弃写入操作

修复方案 #

1. 暂时移除全局吞错的On Error语句，先运行代码定位具体报错行，确认是数据格式问题还是单元格定位问题
2. 增加行合法性校验，对空行、字段数不足的异常行直接跳过，避免单条坏数据中断整个循环
3. 写入合并单元格时，先通过.MergeArea.Cells(1,1)定位到合并区域的左上角单元格再赋值，避免静默写入失败
4. 错误处理逻辑增加错误信息输出，方便后续排查问题

修复后参考代码：

Sub chartTextData(ByVal pathToData As String, dateEarliest As Date, Optional ByVal strFile As String)
    Debug.Print Now() & " chartTextData BEGIN"
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    Dim fso As FileSystemObject
    Set fso = New FileSystemObject
    Dim TxtStream As TextStream
    Dim linebuffer As String
    Dim myArray As Variant
    Dim cellAnchor As Range
    Dim i As Long
    Dim writeVal As Double, writeDate As Date, writeTime As String, writeTech As String
    
    Set cellAnchor = ActiveSheet.Range("D39")
    Set TxtStream = fso.OpenTextFile(pathToData & strFile, ForReading, False, TristateUseDefault)
    
    Do While Not TxtStream.AtEndOfStream
        linebuffer = TxtStream.ReadLine
        ' 跳过空行
        If Len(Trim(linebuffer)) = 0 Then GoTo JumpHereToBypass
        myArray = Split(linebuffer, vbTab, , vbTextCompare)
        ' 跳过字段数不足的行、表头行
        If UBound(myArray) < 4 Then GoTo JumpHereToBypass
        If myArray(1) Like "*DATE*" Then GoTo JumpHereToBypass
        
        ' 校验日期、数值格式，跳过格式非法的行
        On Error Resume Next
        writeDate = CDate(myArray(1))
        writeVal = CDbl(myArray(0))
        If Err.Number <> 0 Then
            Err.Clear
            GoTo JumpHereToBypass
        End If
        On Error GoTo ErrHandler
        
        ' 早于截止日期的行跳过
        If writeDate < dateEarliest Then GoTo JumpHereToBypass
        
        writeTime = myArray(2)
        writeTech = myArray(3)
        
        ' 定位合并单元格左上角后写入
        cellAnchor.Offset(0, i).MergeArea.Cells(1, 1).Value2 = writeVal
        cellAnchor.Offset(3, i).MergeArea.Cells(1, 1).Value2 = writeDate
        cellAnchor.Offset(2, i).MergeArea.Cells(1, 1).Value2 = writeTime
        cellAnchor.Offset(4, i).MergeArea.Cells(1, 1).Value2 = writeTech
        
        i = i + 2
        If i >= 46 Then Exit Do
JumpHereToBypass:
    Loop
    
LoopExit:
    If Not TxtStream Is Nothing Then
        If TxtStream.IsOpen = False Then TxtStream.Close
        Set TxtStream = Nothing
    End If
    Set fso = Nothing
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.Calculate
    Debug.Print Now() & " chartTextData END"
    Exit Sub
ErrHandler:
    Debug.Print "处理行出错：" & linebuffer & "，错误信息：" & Err.Description
    Resume Next
End Sub

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