Question

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

数据描述：大约有15万行的excel文件，其中有针对不同客户的不同贷款的付款。 1个客户可能有几笔不同的贷款。

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

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

我在数据表中大约有12列。 B栏-贷款编号 C列-客户ID
我复制“设置”表中的这两列，并删除“贷款ID”上的重复项-因为我需要为每个“贷款ID”创建单独的Excel文件
然后，打开一个新的工作簿，并一一复制整个数据，并创建一个以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。”

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

PS

我认为它崩溃了-Set nwb = workbooks.add

Answer 1

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

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

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

1 个答案: