如何修复VBA代码ntdll.dll访问违规？大数据拆分崩溃问题

这个问题我之前帮不少人解决过——频繁创建Workbook确实是VBA处理大数据时的常见内存陷阱，尤其是你这种要生成几百个文件的场景。咱们一步步来优化，从根源上解决资源占用过高的问题：

核心崩溃原因分析 #

你提到崩溃点在Set nwb = Workbooks.Add，这完全合理：每新建一个Workbook都会占用大量内存（哪怕是空的），而且Excel对同时打开的Workbook数量/内存占用有隐性限制。加上逐行处理数据、频繁操作文件系统，很容易触发资源耗尽导致的系统级错误（比如ntdll.dll的访问违规）。

具体优化方案 #

1. 先批量创建所有客户文件夹，减少文件系统交互 #

不要边处理数据边创建文件夹，先一次性收集所有唯一客户ID，批量创建文件夹——这样能大幅减少文件系统的IO操作次数，降低资源占用。

Sub CreateCustomerFolders()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("付款数据") '替换成你的数据工作表名
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    Dim dataArr As Variant
    dataArr = ws.Range("A1:" & ws.Cells(lastRow, ws.Columns.Count).End(xlToLeft).Address).Value
    
    '收集唯一客户ID（假设客户ID在第2列，即B列，根据实际调整）
    Dim customerIDs As Collection
    Set customerIDs = New Collection
    On Error Resume Next '忽略重复添加的错误
    For i = 2 To UBound(dataArr, 1) '跳过表头
        customerIDs.Add dataArr(i, 2), Key:=CStr(dataArr(i, 2))
    Next i
    On Error GoTo 0
    
    '批量创建文件夹（替换成你的基础路径）
    Dim basePath As String
    basePath = "D:\付款数据存档\"
    If Right(basePath, 1) <> "\" Then basePath = basePath & "\"
    
    Dim custID As Variant
    For Each custID In customerIDs
        If Dir(basePath & custID, vbDirectory) = "" Then
            MkDir basePath & custID
        End If
    Next custID
End Sub

2. 把所有数据读入数组，避免逐行访问工作表 #

工作表单元格的访问速度极慢，而且会持续占用Excel资源。把整份数据读入内存数组后再处理，效率能提升几十倍。

3. 用字典分组贷款ID数据，提前整理好输出结构 #

用Dictionary把所有数据按贷款ID分组，每个分组存储对应的数据和所属客户ID，这样后续输出时不用反复查找数据，逻辑更清晰。

4. 复用单个临时工作簿，避免频繁新建 #

这是解决内存崩溃的关键！不要每次生成文件都新建Workbook，而是用一个临时Workbook，写完一个贷款ID的数据后清空、再写入下一个，最后统一关闭。

Sub ExportLoanData()
    '先调用上面的文件夹创建函数
    CreateCustomerFolders
    
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("付款数据")
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    Dim dataArr As Variant
    dataArr = ws.Range("A1:" & ws.Cells(lastRow, ws.Columns.Count).End(xlToLeft).Address).Value
    
    '按贷款ID分组数据（假设贷款ID在第3列，C列；客户ID在第2列，B列）
    Dim loanDict As Object
    Set loanDict = CreateObject("Scripting.Dictionary") '后期绑定，无需引用
    
    For i = 2 To UBound(dataArr, 1)
        Dim loanID As String
        loanID = CStr(dataArr(i, 3))
        Dim custID As String
        custID = CStr(dataArr(i, 2))
        
        If Not loanDict.Exists(loanID) Then
            '初始化分组：包含表头+当前行数据
            Dim tempArr As Variant
            ReDim tempArr(1 To 2, 1 To UBound(dataArr, 2))
            '复制表头
            For j = 1 To UBound(dataArr, 2)
                tempArr(1, j) = dataArr(1, j)
                tempArr(2, j) = dataArr(i, j)
            Next j
            loanDict.Add loanID, Array(tempArr, custID)
        Else
            '追加当前行到已有分组
            Dim existingArr As Variant
            existingArr = loanDict(loanID)(0)
            ReDim Preserve existingArr(1 To UBound(existingArr, 1) + 1, 1 To UBound(existingArr, 2))
            For j = 1 To UBound(dataArr, 2)
                existingArr(UBound(existingArr, 1), j) = dataArr(i, j)
            Next j
            loanDict(loanID) = Array(existingArr, loanDict(loanID)(1))
        End If
    Next i
    
    '禁用Excel的资源消耗功能，提升处理速度
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    '创建单个临时工作簿（只带1个工作表，减少默认3个的内存占用）
    Dim tempWB As Workbook
    Set tempWB = Workbooks.Add(xlWBATWorksheet)
    Dim tempWS As Worksheet
    Set tempWS = tempWB.Sheets(1)
    
    Dim basePath As String
    basePath = "D:\付款数据存档\"
    If Right(basePath, 1) <> "\" Then basePath = basePath & "\"
    
    '遍历每个贷款ID，写入并保存
    Dim key As Variant
    For Each key In loanDict.Keys
        Dim currentData As Variant
        currentData = loanDict(key)(0)
        Dim currentCustID As String
        currentCustID = loanDict(key)(1)
        
        '清空临时工作表
        tempWS.Cells.Clear
        
        '写入数据到临时表
        tempWS.Range("A1").Resize(UBound(currentData, 1), UBound(currentData, 2)).Value = currentData
        
        '保存到对应客户文件夹
        Dim savePath As String
        savePath = basePath & currentCustID & "\" & key & ".xlsx"
        tempWB.SaveAs Filename:=savePath, FileFormat:=xlOpenXMLWorkbook
        
        '清理当前数据数组，释放内存
        Erase currentData
    Next key
    
    '关闭临时工作簿，无需保存（已单独保存每个文件）
    tempWB.Close SaveChanges:=False
    
    '释放对象，避免内存泄漏
    Set tempWS = Nothing
    Set tempWB = Nothing
    Set loanDict = Nothing
    Erase dataArr
    
    '恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "数据导出完成！"
End Sub

额外注意事项 #

• 如果你用早期绑定的Dictionary（代码里写Dim loanDict As Dictionary），需要先在VBA编辑器的工具→引用里勾选Microsoft Scripting Runtime；用CreateObject的后期绑定则不需要。
• 请根据你的实际数据调整代码中客户ID、贷款ID的列号（比如第1列是A列，对应数字1）。
• 如果15万行数据导致数组占用内存过高，可以考虑分批次处理（比如每1万行处理一次），但一般来说现代电脑完全能hold住15万行的数组。

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