求助：用VBA从超大量记录的DAT文件指定位置提取字符串

嘿Arturo，我看了你的需求和现有代码，咱们来把它改成能高效处理2200多万条记录的版本！你的原代码其实已经迈出了第一步——读取文件并提取目标字符串，但还缺少写入Excel、列切换和效率优化的关键部分，下面是完整的解决方案：

针对你要处理的22,157,838条超大记录量，我们重点解决效率问题，同时实现「每列存1,048,575条就切换列」的核心需求：

核心改进点 #

• 强制变量声明（避免隐性拼写错误）
• 批量写入Excel（替代逐行写单元格，效率提升100+倍）
• 自动处理列切换逻辑
• 增加错误捕获与文件关闭保障
• 优化大文件读取的稳定性

完整代码 #

Option Explicit

Sub ExtractAndImportToExcel()
    Dim myFile As String
    Dim textLine As String
    Dim cuenta As String
    Dim ws As Worksheet
    Dim currentRow As Long
    Dim currentCol As Long
    Dim batchArr() As String
    Dim batchSize As Long
    Dim batchIndex As Long
    
    ' 配置参数
    myFile = "C:\Users\s3850630\Desktop\EXPMST.dat"
    batchSize = 10000 ' 每次批量写入的行数，内存充足可设为50000
    currentRow = 1 ' 起始行号
    currentCol = 1 ' 起始列号
    batchIndex = 0
    
    ' 指定要写入的工作表（可改成Sheets("你的表名")）
    Set ws = ActiveSheet
    ' 清空目标区域（可选，按需保留）
    ws.Cells.Clear
    
    ' 错误捕获：确保文件无论如何都会关闭
    On Error GoTo Cleanup
    
    ' 打开目标DAT文件
    Open myFile For Input As #1
    
    ' 初始化批量存储数组
    ReDim batchArr(1 To batchSize)
    
    Do Until EOF(1)
        ' 读取一行并提取第15位开始的30位字符串
        Line Input #1, textLine
        cuenta = Mid(textLine, 15, 30)
        
        ' 将数据加入批量数组
        batchIndex = batchIndex + 1
        batchArr(batchIndex) = cuenta
        
        ' 当批量数组满，或当前列即将达到行数上限时，写入Excel
        If batchIndex = batchSize Or currentRow + batchIndex > 1048575 Then
            ' 批量写入到Excel（转置数组适配列方向）
            ws.Cells(currentRow, currentCol).Resize(batchIndex, 1).Value = Application.Transpose(batchArr)
            
            ' 更新当前行号
            currentRow = currentRow + batchIndex
            
            ' 重置批量数组和索引
            ReDim batchArr(1 To batchSize)
            batchIndex = 0
            
            ' 检查是否需要切换到下一列
            If currentRow > 1048575 Then
                currentCol = currentCol + 1
                currentRow = 1
            End If
        End If
    Loop
    
    ' 写入剩余的不足一批的数据
    If batchIndex > 0 Then
        ReDim Preserve batchArr(1 To batchIndex)
        ws.Cells(currentRow, currentCol).Resize(batchIndex, 1).Value = Application.Transpose(batchArr)
    End If
    
Cleanup:
    ' 强制关闭文件，避免锁定
    If Not EOF(1) Then Close #1
    Close #1
    
    ' 恢复Excel默认设置（如果之前关闭了）
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    ' 提示完成信息
    MsgBox "数据提取导入完成！共处理到第" & currentCol & "列，最后一行是" & currentRow + batchIndex - 1 & "行", vbInformation
End Sub

额外效率优化建议 #

如果你的电脑配置不错，还可以在代码开头加上这两行，进一步提升速度：

Application.ScreenUpdating = False ' 关闭屏幕刷新
Application.Calculation = xlCalculationManual ' 关闭自动计算

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