批量读取数千CSV时FreeFile触发Error 67的解决及替代方案

需要读取多文件夹下的数千个CSV文件，仅提取每个文件的最后一行数据做分析，用FreeFile实现（PowerQuery不适用此场景）。曾临时把文件句柄扩展到512，但这不是根本解决办法。

就算关闭文件，内存也没正确释放，循环处理一定数量的文件后会触发Error 67（文件过多）。尝试循环直到FreeFile返回1（还加了Sleep延迟）也没用，FreeFile最终会涨到2。

编写了Return_VarInCSVLine函数来获取指定行数据：

Function Return_VarInCSVLine(ByRef NumLineToReturnTo As Long, ByRef TxtFilePathCSV As String, Optional ByRef IsLastLine As Boolean) As Variant
If NumLineToReturnTo = 0 Then NumLineToReturnTo = 1
'NumLineToReturnTo has to be at least 1 even if LastLine is set to true so no error is arised from IIF
Dim NumFileInMemory As Long
Dim ArrVarTxtLines() As Variant
Dim CounterArrTxtLines As Long
Dim TxtInLine As String
    NumFileInMemory = FreeFile: CounterArrTxtLines = 1
    Open TxtFilePathCSV For Input As #NumFileInMemory: DoEvents
    Do While Not EOF(NumFileInMemory)
    Line Input #NumFileInMemory, TxtInLine
    ReDim Preserve ArrVarTxtLines(1 To CounterArrTxtLines)
    ArrVarTxtLines(CounterArrTxtLines) = TxtInLine
    CounterArrTxtLines = CounterArrTxtLines + 1
    Loop
LoopUntilClosed:
    Close #NumFileInMemory: Sleep (10): DoEvents
    NumFileInMemory = FreeFile
    If NumFileInMemory > 1 Then GoTo LoopUntilClosed
    Return_VarInCSVLine = IIf(IsLastLine = True, ArrVarTxtLines(UBound(ArrVarTxtLines)), ArrVarTxtLines(NumLineToReturnTo))
End Function

错误修复：优化现有代码 #

当前代码的核心问题是读取并存储整个文件内容，既浪费内存，又拉长了文件句柄的占用时间；另外LoopUntilClosed循环完全没必要——FreeFile返回大于1只是系统缓存了句柄编号，不是文件没关闭，强行循环反而拖慢程序。

针对「仅需最后一行」的核心需求，修改代码如下，只保留最后一行数据，大幅减少内存占用和句柄使用时长：

Function Return_VarInCSVLine(ByRef NumLineToReturnTo As Long, ByRef TxtFilePathCSV As String, Optional ByRef IsLastLine As Boolean) As Variant
    If NumLineToReturnTo = 0 Then NumLineToReturnTo = 1
    Dim NumFileInMemory As Long
    Dim TxtInLine As String
    Dim lastLine As String
    Dim lineCount As Long
    
    NumFileInMemory = FreeFile
    Open TxtFilePathCSV For Input As #NumFileInMemory
    Do While Not EOF(NumFileInMemory)
        Line Input #NumFileInMemory, TxtInLine
        lineCount = lineCount + 1
        ' 只保留最后一行，不存储所有行
        lastLine = TxtInLine
    Loop
    Close #NumFileInMemory
    
    If IsLastLine Then
        Return_VarInCSVLine = lastLine
    Else
        ' 若需指定行，重新读取到目标行即可
        Open TxtFilePathCSV For Input As #NumFileInMemory
        lineCount = 0
        Do While Not EOF(NumFileInMemory) And lineCount < NumLineToReturnTo
            Line Input #NumFileInMemory, TxtInLine
            lineCount = lineCount + 1
        Loop
        Close #NumFileInMemory
        Return_VarInCSVLine = TxtInLine
    End If
End Function

替代方案 #

1. 使用FileSystemObject（FSO）读取最后一行 #

语法更直观，性能与FreeFile接近：

Function GetCSVLastLine(ByVal filePath As String) As String
    Dim fso As Object
    Dim txtStream As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set txtStream = fso.OpenTextFile(filePath, 1) ' 1=只读模式
    
    Dim lastLine As String
    Do While Not txtStream.AtEndOfStream
        lastLine = txtStream.ReadLine
    Loop
    
    txtStream.Close
    Set txtStream = Nothing
    Set fso = Nothing
    GetCSVLastLine = lastLine
End Function

2. 直接读取文件尾部（最高效） #

无需读取整个文件，仅从文件末尾往前查找换行符，速度极快，适合大文件批量处理：

Function GetCSVLastLineFast(ByVal filePath As String) As String
    Dim fileNum As Long
    Dim fileSize As Long
    Dim buffer As String
    Dim pos As Long
    
    fileNum = FreeFile
    Open filePath For Binary As #fileNum
    fileSize = LOF(fileNum)
    
    ' 读取文件末尾最多1024字节（足够覆盖一行CSV内容）
    buffer = Space$(Min(1024, fileSize))
    Get #fileNum, fileSize - Len(buffer) + 1, buffer
    
    ' 定位最后一个换行符
    pos = InStrRev(buffer, vbCrLf)
    If pos > 0 Then
        GetCSVLastLineFast = Mid(buffer, pos + 2)
    Else
        ' 文件只有一行，直接读取全部内容
        buffer = Space$(fileSize)
        Get #fileNum, 1, buffer
        GetCSVLastLineFast = buffer
    End If
    
    Close #fileNum
End Function

Function Min(a As Long, b As Long) As Long
    If a < b Then Min = a Else Min = b
End Function

3. 批量处理补充优化 #

每次处理完文件后，可添加以下代码强制释放资源（作为补充优化）：

DoEvents
CollectGarbage

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