我需要按客户和每个客户的贷款来划分收款数据,并将它们保存到不同文件夹中的不同excel文件中。让我详细解释。
数据描述:有一个大约15万行的excel文件,其中有不同客户的不同贷款的还款额。 1个客户可能有几笔不同的贷款。
1)以客户端ID为名称为每个客户端创建一个文件夹。2)为每笔贷款创建一个单独的excel文件,并且仅包括该笔贷款的经过过滤的付款。使用客户ID文件夹下的贷款ID名称保存此excel文件。 (是的,某些文件夹将包含几个excel文件)。
我是编码的新手,所以经过大量的google和youtube之后,我想到了下面的代码。
-
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
事实证明,问题在于打开太多新工作簿并关闭它们。似乎超负荷表现得太多了。因此,我没有在循环中创建新的工作簿,而是在其之前创建了一个工作簿,然后在循环内部将其清除。代码变得如此之快,并且效果也很好。
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