Excel 如果我在整个文件上使用 运行 子例程但分段工作正常，则 Excel 会崩溃
Excel crashes if I run subroutine on entire file but works fine in segments
我在 VBA 中编写了一个子例程，用于将图像插入产品 sku 的传播sheet（图像以 sku 命名）。我已经做了我能想到的尽可能多的错误处理，并且代码在小批量中运行良好（包括错误处理）；但是当我 运行 在整个 spreadsheet （2400 行）上使用它时，它每次遇到图像不存在的 sku 时都会崩溃，即使这些实例在我通过时得到了正确处理调试器。
我的第一个想法是 Excel 处理起来太多了，所以我尝试添加一个暂停（也许是一个长镜头）——这没有用。
我粘贴了下面的代码 - 以前有人遇到过这个吗？
为了进一步解释代码，在 sku 列旁边有一些关联产品，所以我们的想法是，如果主图像不存在，我们可以遍历关联产品并尝试使用其中之一 -如果仍然没有任何匹配的图像，那么主 sku 应该存储在一个数组中，然后放在一个新的 sheet 上以供在子例程结束时参考 - 在调试时一切正常，但在 [= 时崩溃22=] 在整个文件上。
Sub InsertPic()
Dim MySht As Worksheet
Dim MyPic As Shape
Dim MyLeft As Single, MyTop As Single
Dim noImage() As String
Dim noImageSheet As Worksheet
'stop screen updating
Application.ScreenUpdating = False
Application.DisplayAlerts = False
masterSpreadsheet = ActiveSheet.Name
lastRow = Cells(Rows.Count, 2).End(xlUp).Row
'define first part of noImage array
k = 0
Set MySht = ActiveSheet
For i = 2 To lastRow
'save every 100 images
shouldISave = i Mod 100
If shouldISave = 0 Then
ActiveWorkbook.Save
End If
'If i Mod 50 = 0 Then
' Application.Wait (Now + TimeValue("0:00:05"))
'End If
MyTop = Rows(Cells(i, 1).Row).Top + 1
MyLeft = Columns(Cells(i, 1).Column).Left + 1
'turn off error checking
On Error Resume Next
'try to define image based on main sku
Set MyPic = MySht.Shapes.AddPicture("W:\Design on 'Pmcsbs' (Y)\Brochure\" & Cells(i, 2) & ".jpg", _
msoFalse, msoTrue, MyLeft, MyTop, -1, -1)
'use fallback images from associated products
'check if MyPic is set
If MyPic Is Nothing Then
'Split associated products into array
scndImage = Split(Cells(i, 3), ",")
'check that array is not empty
On Error Resume Next
isItEmpty = scndImage(0)
If Len(isItEmpty) > 0 Then
j = 0
'loop through array while picture isn't set
Do While MyPic Is Nothing
'try to set the picture with each assoc product code
Set MyPic = MySht.Shapes.AddPicture("W:\Design on 'Pmcsbs' (Y)\Brochure\" & scndImage(j) & ".jpg", _
msoFalse, msoTrue, MyLeft, MyTop, -1, -1)
j = j + 1
'stop the loop when we reach the upper limit of the array
If j = UBound(scndImage) + 1 Then
Exit Do
End If
Loop
End If
End If
'check if picture still doesn't exist after all codes have been tried
If MyPic Is Nothing Then
ReDim Preserve noImage(k) As String
noImage(k) = Cells(i, 2)
k = k + 1
End If
'turn error checking back on
On Error GoTo 0
'only run the below if MyPic exists
If Not MyPic Is Nothing Then
' now resize pic
MyPic.Height = Cells(i, 1).Height - 2
If MyPic.Width > Cells(i, 1).Width Then
MyPic.Width = Cells(i, 1).Width
End If
End If
Set MyPic = Nothing
Next
'if noImage has data in then print that to a new sheet
On Error Resume Next
isItEmpty2 = noImage(0)
noImgLastRow = 1
If Len(isItEmpty2) > 0 Then
'check if no image sheet exists and get lastRow if it does
On Error Resume Next
Set noImageSheet = Sheets("No Images")
On Error GoTo 0
'if it doesn't exist create it
If noImageSheet Is Nothing Then
Sheets.Add.Name = "No Images"
'if it does, update the last row number
Else
noImgLastRow = noImageSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
End If
m = 1
For l = 0 To UBound(noImage)
Sheets("No Images").Cells(noImgLastRow, 1) = noImage(l)
m = m + 1
noImgLastRow = noImgLastRow + 1
Next
End If
Sheets(masterSpreadsheet).Activate
ActiveWorkbook.Save
'email Jack to confirm it has completed
Call Mail_images_spreadsheet_finished
'Update screen again
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
需要重置禁用错误检查 - 这些说明成对出现。在您的代码中，您为每一行禁用了 EC 两次，但只再次启用了一次。这会导致内存消耗增加并最终崩溃 Excel。
我提出以下更改：
' turn off error checking
On Error Resume Next
'try to define image based on main sku
Set MyPic = MySht.Shapes.AddPicture("W:\Design on 'Pmcsbs' (Y)\Brochure\" & Cells(i, 2) & ".jpg", _
msoFalse, msoTrue, MyLeft, MyTop, -1, -1)
On Error GoTo 0 ' <~~ reset EC
...
再次在这里：
On Error Resume Next
isItEmpty = scndImage(0)
' many many lines of code following
...
'turn error checking back on
On Error GoTo 0
更改为：
On Error Resume Next
isItEmpty = scndImage(0)
'turn error checking back on
On Error GoTo 0 ' <~~
' many many lines of code following
...
和
'if noImage has data in then print that to a new sheet
On Error Resume Next
isItEmpty2 = noImage(0)
On Error Goto 0 ' <~~
然后，您的代码仍然包含使用 On Error Resume Next 时常见的错误。如果你有
On Error Resume Next
set testvar = myarray(indx)
On Error Goto 0
if testvar is Nothing then ' element does not exist
那么如果数组元素不存在，set testvar语句将被跳过。假设测试为阳性，设置testvar；如果在下一个循环迭代中测试失败 if testvar is Nothing 将是 False 尽管赋值失败。在尝试分配之前，您必须重置 testvar！
set testvar = Nothing ' <~~ !!!
On Error Resume Next
set testvar = myarray(indx)
On Error Goto 0
if testvar is Nothing then ' element does not exist
在您的代码中，这会影响 MyPic 和 isItEmpty 以及 isItEmpty2。
我在 VBA 中编写了一个子例程，用于将图像插入产品 sku 的传播sheet（图像以 sku 命名）。我已经做了我能想到的尽可能多的错误处理，并且代码在小批量中运行良好（包括错误处理）；但是当我 运行 在整个 spreadsheet （2400 行）上使用它时，它每次遇到图像不存在的 sku 时都会崩溃，即使这些实例在我通过时得到了正确处理调试器。 我的第一个想法是 Excel 处理起来太多了，所以我尝试添加一个暂停（也许是一个长镜头）——这没有用。
我粘贴了下面的代码 - 以前有人遇到过这个吗？
为了进一步解释代码，在 sku 列旁边有一些关联产品，所以我们的想法是，如果主图像不存在，我们可以遍历关联产品并尝试使用其中之一 -如果仍然没有任何匹配的图像，那么主 sku 应该存储在一个数组中，然后放在一个新的 sheet 上以供在子例程结束时参考 - 在调试时一切正常，但在 [= 时崩溃22=] 在整个文件上。
Sub InsertPic()
Dim MySht As Worksheet
Dim MyPic As Shape
Dim MyLeft As Single, MyTop As Single
Dim noImage() As String
Dim noImageSheet As Worksheet
'stop screen updating
Application.ScreenUpdating = False
Application.DisplayAlerts = False
masterSpreadsheet = ActiveSheet.Name
lastRow = Cells(Rows.Count, 2).End(xlUp).Row
'define first part of noImage array
k = 0
Set MySht = ActiveSheet
For i = 2 To lastRow
'save every 100 images
shouldISave = i Mod 100
If shouldISave = 0 Then
ActiveWorkbook.Save
End If
'If i Mod 50 = 0 Then
' Application.Wait (Now + TimeValue("0:00:05"))
'End If
MyTop = Rows(Cells(i, 1).Row).Top + 1
MyLeft = Columns(Cells(i, 1).Column).Left + 1
'turn off error checking
On Error Resume Next
'try to define image based on main sku
Set MyPic = MySht.Shapes.AddPicture("W:\Design on 'Pmcsbs' (Y)\Brochure\" & Cells(i, 2) & ".jpg", _
msoFalse, msoTrue, MyLeft, MyTop, -1, -1)
'use fallback images from associated products
'check if MyPic is set
If MyPic Is Nothing Then
'Split associated products into array
scndImage = Split(Cells(i, 3), ",")
'check that array is not empty
On Error Resume Next
isItEmpty = scndImage(0)
If Len(isItEmpty) > 0 Then
j = 0
'loop through array while picture isn't set
Do While MyPic Is Nothing
'try to set the picture with each assoc product code
Set MyPic = MySht.Shapes.AddPicture("W:\Design on 'Pmcsbs' (Y)\Brochure\" & scndImage(j) & ".jpg", _
msoFalse, msoTrue, MyLeft, MyTop, -1, -1)
j = j + 1
'stop the loop when we reach the upper limit of the array
If j = UBound(scndImage) + 1 Then
Exit Do
End If
Loop
End If
End If
'check if picture still doesn't exist after all codes have been tried
If MyPic Is Nothing Then
ReDim Preserve noImage(k) As String
noImage(k) = Cells(i, 2)
k = k + 1
End If
'turn error checking back on
On Error GoTo 0
'only run the below if MyPic exists
If Not MyPic Is Nothing Then
' now resize pic
MyPic.Height = Cells(i, 1).Height - 2
If MyPic.Width > Cells(i, 1).Width Then
MyPic.Width = Cells(i, 1).Width
End If
End If
Set MyPic = Nothing
Next
'if noImage has data in then print that to a new sheet
On Error Resume Next
isItEmpty2 = noImage(0)
noImgLastRow = 1
If Len(isItEmpty2) > 0 Then
'check if no image sheet exists and get lastRow if it does
On Error Resume Next
Set noImageSheet = Sheets("No Images")
On Error GoTo 0
'if it doesn't exist create it
If noImageSheet Is Nothing Then
Sheets.Add.Name = "No Images"
'if it does, update the last row number
Else
noImgLastRow = noImageSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
End If
m = 1
For l = 0 To UBound(noImage)
Sheets("No Images").Cells(noImgLastRow, 1) = noImage(l)
m = m + 1
noImgLastRow = noImgLastRow + 1
Next
End If
Sheets(masterSpreadsheet).Activate
ActiveWorkbook.Save
'email Jack to confirm it has completed
Call Mail_images_spreadsheet_finished
'Update screen again
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
需要重置禁用错误检查 - 这些说明成对出现。在您的代码中，您为每一行禁用了 EC 两次，但只再次启用了一次。这会导致内存消耗增加并最终崩溃 Excel。 我提出以下更改：
' turn off error checking
On Error Resume Next
'try to define image based on main sku
Set MyPic = MySht.Shapes.AddPicture("W:\Design on 'Pmcsbs' (Y)\Brochure\" & Cells(i, 2) & ".jpg", _
msoFalse, msoTrue, MyLeft, MyTop, -1, -1)
On Error GoTo 0 ' <~~ reset EC
...
再次在这里：
On Error Resume Next
isItEmpty = scndImage(0)
' many many lines of code following
...
'turn error checking back on
On Error GoTo 0
更改为：
On Error Resume Next
isItEmpty = scndImage(0)
'turn error checking back on
On Error GoTo 0 ' <~~
' many many lines of code following
...
和
'if noImage has data in then print that to a new sheet
On Error Resume Next
isItEmpty2 = noImage(0)
On Error Goto 0 ' <~~
然后，您的代码仍然包含使用 On Error Resume Next 时常见的错误。如果你有
On Error Resume Next
set testvar = myarray(indx)
On Error Goto 0
if testvar is Nothing then ' element does not exist
那么如果数组元素不存在，set testvar语句将被跳过。假设测试为阳性，设置testvar；如果在下一个循环迭代中测试失败 if testvar is Nothing 将是 False 尽管赋值失败。在尝试分配之前，您必须重置 testvar！
set testvar = Nothing ' <~~ !!!
On Error Resume Next
set testvar = myarray(indx)
On Error Goto 0
if testvar is Nothing then ' element does not exist
在您的代码中，这会影响 MyPic 和 isItEmpty 以及 isItEmpty2。