如何解决错误-“模块'ntdll.dll'中的访问冲突”? VBA代码崩溃

问题描述 投票:0回答:1

我需要按客户和每个客户的贷款来划分收款数据,并将它们保存到不同文件夹中的不同excel文件中。让我详细解释。

数据描述:有一个大约15万行的excel文件,其中有不同客户的不同贷款的还款额。 1个客户可能有几笔不同的贷款。

1)以客户端ID为名称为每个客户端创建一个文件夹。2)为每笔贷款创建一个单独的excel文件,并且仅包括该笔贷款的经过过滤的付款。使用客户ID文件夹下的贷款ID名称保存此excel文件。 (是的,某些文件夹将包含几个excel文件)。

我是编码的新手,所以经过大量的google和youtube之后,我想到了下面的代码。

  1. 我在数据表中大约有12列。 B栏-贷款编号C列-客户ID
  2. 我复制了“设置”表中的这两列,并删除了贷款ID上的重复项-因为我需要为每个贷款ID创建单独的Excel文件
  3. [然后,打开一个新工作簿,并一一复制整个数据,并创建一个以CLIENT ID作为名称的文件夹。

-

Sub Split_excel_into_folders()

    Set data_sh = ThisWorkbook.Sheets("Data")

    Dim setting_Sh As Worksheet
    Set setting_Sh = ThisWorkbook.Sheets("Settings")

    Dim nwb As Workbook
    Dim nsh As Worksheet

    'Get unique loan ids
    setting_Sh.Range("A:B").Clear
    data_sh.AutoFilterMode = False
    data_sh.Range("B:C").Copy setting_Sh.Range("A1")
    setting_Sh.Range("A:B").RemoveDuplicates 1, xlYes

    Dim i As Integer
    For i = 2 To Application.CountA(setting_Sh.Range("A:A"))
        data_sh.UsedRange.AutoFilter 2, setting_Sh.Range("A" & i).Value
        Set nwb = Workbooks.Add
        Set nsh = nwb.Sheets(1)
        data_sh.UsedRange.SpecialCells(xlCellTypeVisible).Copy nsh.Range("A1")
        nsh.UsedRange.EntireColumn.ColumnWidth = 25
        Dim path As String
        Dim Folder As String
        path = setting_Sh.Range("H6").Value & "\" & setting_Sh.Range("B" & i).Value
        Folder = Dir(path, vbDirectory)
        If Folder = VBA.vbNullString Then
            VBA.MkDir (path)
        End If
        nwb.SaveAs setting_Sh.Range("H6").Value & "\" & setting_Sh.Range("B" & i).Value & "/" & setting_Sh.Range("A" & i).Value & ".xlsx"
        nwb.Close False
        data_sh.AutoFilterMode = False
    Next i

    setting_Sh.Range("A:A").Clear
    MsgBox "Done"

End Sub

该代码实际上可以实现奇迹,但仅适用于小数据。它开始创建文件夹并保存excel,但是在创建大约283个文件夹后崩溃。错误:

“模块'ntdll.dll'中地址00007FFE7E3EBE6B的访问冲突。写入地址0000000000000024。

我已经测试了很多次,有时由于内存不足而崩溃。我想我需要对其进行一些优化,以免消耗更少的资源。你能帮我吗?

P.S

我认为它在行上崩溃-Set nwb = workbooks.add

excel vba
1个回答
0
投票

事实证明,问题在于打开太多新工作簿并关闭它们。似乎超负荷表现得太多了。因此,我没有在循环中创建新的工作簿,而是在其之前创建了一个工作簿,然后在循环内部将其清除。代码变得如此之快,并且效果也很好。

Sub Split_excel_into_folders()Set data_sh = ThisWorkbook.Sheets("Data")
Dim setting_Sh As Worksheet
Set setting_Sh = ThisWorkbook.Sheets("Settings")
Dim nwb As Workbook
Dim nsh As Worksheet
Set nwb = Workbooks.Add
Set nsh = nwb.Sheets(1)
''''' Get unique loan ids
setting_Sh.Range("A:A").Clear
data_sh.AutoFilterMode = False
data_sh.Range("B:C").Copy setting_Sh.Range("A1")
setting_Sh.Range("A:B").RemoveDuplicates 1, xlYes
Dim i As Integer
For i = 2 To Application.CountA(setting_Sh.Range("A:A"))
data_sh.UsedRange.AutoFilter 2, setting_Sh.Range("A" & i).Valuedata_sh.UsedRange.SpecialCells(xlCellTypeVisible).Copy nsh.Range("A1")
nsh.UsedRange.EntireColumn.ColumnWidth = 25
Dim path As String
Dim Folder As String
path = setting_Sh.Range("H6").Value & "\" & setting_Sh.Range("B" & i).Value
Folder = Dir(path, vbDirectory)
If Folder = VBA.vbNullString Then
VBA.MkDir (path)
End If
nwb.SaveAs setting_Sh.Range("H6").Value & "\" & setting_Sh.Range("B" & i).Value & "/" & setting_Sh.Range("A" & i).Value & ".xlsx"
nsh.Range("A:AA").Clear
data_sh.AutoFilterMode = False
Next i
setting_Sh.Range("A:B").Clear
nwb.Close False
MsgBox "Done"
End Sub
© www.soinside.com 2019 - 2024. All rights reserved.