我有一个包含大约 10K 条记录的 Excel 文件，我将其拆分为多个文件。全部具有相同的结构，但每个大约有 1500 条记录。 1 个文件包含剩余的 900 条记录加上 1500 条记录（因此，大约 2500 条左右）。我正在针对这些文件运行以下 VBA 脚本。该脚本已成功针对其中 2 个文件运行。但是，当我尝试针对下一个文件运行脚本时，出现内存不足错误。但该文件的大小与其他文件基本相同（1500 条记录）。我什至重新启动了机器，但仍然出现错误。尝试询问人工智能，但没有任何帮助。
我正在使用的机器有 64 GB RAM，核心 i9，我使用的是 excel 365（已更新到我的发布环）。
为什么脚本在文件的其他 2 个副本中成功运行，但在第 3 个副本中却不能运行？？？
Sub CleanAccentsInData()
Dim ws As Worksheet
Dim rng As Range
Dim dataArray As Variant
Dim i As Long, j As Long, batchSize As Long, batchStart As Long
Dim lastRow As Long
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
' Set the worksheet name where your data is located
On Error Resume Next
Set ws = ThisWorkbook.Sheets("EvaCombined4") ' Replace " EvaCombined4" with your actual sheet name
If ws Is Nothing Then
MsgBox "Sheet not found, check the name and try again.", vbCritical
GoTo CleanUp
End If
On Error GoTo 0
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
batchSize = 20 ' Try an even smaller batch size
' Process data in batches
For batchStart = 2 To lastRow Step batchSize
Set rng = ws.Range(ws.Cells(batchStart, 1), ws.Cells(Min(batchStart + batchSize - 1, lastRow), 43))
dataArray = rng.Value
' Process each cell in the array
For i = 1 To UBound(dataArray, 1)
For j = 1 To UBound(dataArray, 2)
If VarType(dataArray(i, j)) = vbString And Not IsEmpty(dataArray(i, j)) Then
dataArray(i, j) = CleanText(CStr(dataArray(i, j)))
End If
Next j
Next i
rng.Value = dataArray ' Write back the processed data
Set rng = Nothing ' Explicitly clear the range object
Erase dataArray ' Clear the array
Next batchStart
CleanUp:
If Not ws Is Nothing Then Set ws = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Data cleaning complete!", vbInformation
End Sub
Function Min(a As Long, b As Long) As Long
If a < b Then
Min = a
Else
Min = b
End If
End Function
Function CleanText(ByVal text As String) As String
Dim result As String
Dim ch As String
Dim i As Integer
Const AccChars = "àáâãäåçèéêëìíîïðñòóôõöùúûüýÿÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖÙÚÛÜÝ"
Const RegChars = "aaaaaaceeeeiiiionooooouuuuyyAAAAAACEEEEIIIIONOOOOOUUUUY"
result = text
For i = 1 To Len(AccChars)
result = Replace(result, Mid(AccChars, i, 1), Mid(RegChars, i, 1))
Next i
CleanText = ""
For i = 1 To Len(result)
ch = Mid(result, i, 1)
If ch Like "[a-zA-Z] " Then
CleanText = CleanText & ch
End If
Next i
If Len(CleanText) = 0 Then CleanText = result ' Return original if cleaning results in an empty string
End Function
AccCharsUnicodeLikeOption Explicit
Const RegChars = "aaaaaaceeeeiiiionooooouuuuyyAAAAAACEEEEIIIIONOOOOOUUUUY"
Dim AccChars As String
Sub DefineChars()
' Const AccChars = "aáâaäaçeéeëiíîi?noóôoöuúuüýyAÁÂAÄAÇEÉEËIÍÎI?NOÓÔOÖUÚUÜÝ"
Dim ach As Variant, a As Variant
ach = Array(224, 225, 226, 227, 228, 229, 231, 232, 233, 234, 235, 236, 237, 238, 239, 240, _
241, 242, 243, 244, 245, 246, 249, 250, 251, 252, 253, 255, 192, 193, 194, 195, _
196, 197, 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, 211, 212, _
213, 214, 217, 218, 219, 220, 221)
' 224:229, 231:246, 249:253, 255, 192:197, 199:214, 217:221
For Each a In ach
AccChars = AccChars & ChrW(a)
Next a
End Sub
Sub CleanAccentsInData()
Dim ws As Worksheet
Dim rng As Range
Dim dataArray As Variant
Dim i As Long, j As Long, batchSize As Long, batchStart As Long
Dim lastRow As Long
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
' Set the worksheet name where your data is located
On Error Resume Next
Set ws = ThisWorkbook.Sheets("EvaCombined4") ' Replace " EvaCombined4" with your actual sheet name
If ws Is Nothing Then
MsgBox "Sheet not found, check the name and try again.", vbCritical
GoTo CleanUp
End If
On Error GoTo 0
DefineChars
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
batchSize = 20 ' Try an even smaller batch size
' Process data in batches
For batchStart = 2 To lastRow Step batchSize
Set rng = ws.Range(ws.Cells(batchStart, 1), ws.Cells(Min(batchStart + batchSize - 1, lastRow), 43))
dataArray = rng.Value
' Process each cell in the array
For i = 1 To UBound(dataArray, 1)
For j = 1 To UBound(dataArray, 2)
If VarType(dataArray(i, j)) = vbString And Not IsEmpty(dataArray(i, j)) Then
dataArray(i, j) = CleanText(CStr(dataArray(i, j)))
End If
Next j
Next i
rng.Value = dataArray ' Write back the processed data
Set rng = Nothing ' Explicitly clear the range object
Erase dataArray ' Clear the array
Next batchStart
CleanUp:
If Not ws Is Nothing Then Set ws = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Data cleaning complete!", vbInformation
End Sub
Function Min(a As Long, b As Long) As Long
If a < b Then
Min = a
Else
Min = b
End If
End Function
Function CleanText(ByVal text As String) As String
Dim result As String
Dim ch As String
Dim i As Integer
result = text
For i = 1 To Len(AccChars)
result = Replace(result, Mid(AccChars, i, 1), Mid(RegChars, i, 1))
Next i
CleanText = ""
For i = 1 To Len(result)
ch = Mid(result, i, 1)
If ch Like "[a-zA-Z ]" Then ' <- change here
CleanText = CleanText & ch
End If
Next i
If Len(CleanText) = 0 Then CleanText = result ' Return original if cleaning results in an empty string
End Function