Excel文件在运行代码时有时会崩溃和关闭，如何防止它？

我有一个简单的代码，可以将一张工作表中的所有内容复制并粘贴到另一张工作表中，大多数情况下，在代码完成后，运行excel文件会关闭并再次打开（但没有任何信息）

该代码是从userform中的CommandButton1调用的。我将代码放入用户表单中，因为我正在使用列表框选择正确的工作表来复制信息

Private Sub CommandButton1_Click()

Application.ScreenUpdating = False: Application.DisplayAlerts = False: Application.AskToUpdateLinks = False: Application.EnableEvents = False 'For less lag

Application.Calculation = xlCalculationManual

Dim sheet_name As String
Dim oShape As Shape

Alert.Rows("15:" & Rows.count).ClearContents

 Alert.Activate

For Each oShape In ActiveSheet.Shapes
    If Not Application.Intersect(oShape.TopLeftCell, ActiveSheet.Rows("15:" & Rows.count)) Is Nothing Then
        oShape.Delete
    End If
Next

Dim i As Integer, sht As String
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) = True Then
            sht = ListBox1.List(i)
        End If
    Next i
    Sheets(sht).Activate

    Application.EnableEvents = False

ActiveSheet.Range("A15:L345").Copy Alert.Range("A15")
Alert.Range("C1:C2").Value = ActiveSheet.Range("C1:C2").Value
Alert.Range("H2:L3").Value = ActiveSheet.Range("H2:L3").Value
Alert.Range("H5:L10").Value = ActiveSheet.Range("H5:L10").Value

Alert.Range("B34") = ActiveSheet.Name

ActiveSheet.Delete

 Call rename

 Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True: Application.DisplayAlerts = True: Application.AskToUpdateLinks = True: Application.EnableEvents = True

End Sub

重命名子代码也是一个简单的代码

Sub rename()

Dim ws As Worksheet

Application.ScreenUpdating = False: Application.DisplayAlerts = False: Application.AskToUpdateLinks = False: Application.EnableEvents = False 'For less lag

Alert.Activate

Alert.Name = Alert.Range("B34")
Alert.Range("B34") = ""

Range("L2:L3").Select
Range("L5:L10").Select
With Selection
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
           End With
     With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
           End With

Alert.Range("A1").Activate

Application.ScreenUpdating = True: Application.DisplayAlerts = True: Application.AskToUpdateLinks = True: Application.EnableEvents = True

End Sub

---

如何防止它崩溃

我建议使用

DoEvents

并避免

select

和

activate

    Private Sub CommandButton1_Click()

    Application.ScreenUpdating = False: Application.DisplayAlerts = False: 
    Application.AskToUpdateLinks = False: Application.EnableEvents = False 'For less lag

    Application.Calculation = xlCalculationManual

    Dim sheet_name As String
    Dim oShape As Shape

    Alert.Rows("15:" & Rows.count).ClearContents

    Alert.Activate
    DoEvents
    For Each oShape In Alert.Shapes
    If Not Application.Intersect(oShape.TopLeftCell, Alert.Rows("15:" & Alert.Rows.count)) Is Nothing Then
            oShape.Delete
        End If
    Next

    Dim i As Integer, sht As String
    DoEvents
        For i = 0 To ListBox1.ListCount - 1
            If ListBox1.Selected(i) = True Then
                sht = ListBox1.List(i)
            End If
        Next i

        Application.EnableEvents = False

    Sheets(sht).Range("A15:L345").Copy Alert.Range("A15")
    Alert.Range("C1:C2").Value = Sheets(sht).Range("C1:C2").Value
    Alert.Range("H2:L3").Value = Sheets(sht).Range("H2:L3").Value
    Alert.Range("H5:L10").Value = Sheets(sht).Range("H5:L10").Value

    Alert.Range("B34") = Sheets(sht).Name

    Sheets(sht).Delete

     Call rename

     Application.Calculation = xlCalculationAutomatic

    Application.ScreenUpdating = True: Application.DisplayAlerts = True: 
    Application.AskToUpdateLinks = True: Application.EnableEvents = True

    End Sub


    Sub rename()

    Dim ws As Worksheet

    Application.ScreenUpdating = False: Application.DisplayAlerts = False: Application.AskToUpdateLinks = False: Application.EnableEvents = False 'For less lag


    Alert.Name = Alert.Range("B34")
    Alert.Range("B34") = ""

    DoEvents
With Alert.Range("L5:L10")
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
 End With
DoEvents
With Alert.Range("L2:L3")
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
 End With

    Application.ScreenUpdating = True: Application.DisplayAlerts = True: 
    Application.AskToUpdateLinks = True: Application.EnableEvents = True

    End Sub

---

我建议使用

DoEvents

，并避免

select

和

activate

    Private Sub CommandButton1_Click()

    Application.ScreenUpdating = False: Application.DisplayAlerts = False: 
    Application.AskToUpdateLinks = False: Application.EnableEvents = False 'For less lag

    Application.Calculation = xlCalculationManual

    Dim sheet_name As String
    Dim oShape As Shape

    Alert.Rows("15:" & Rows.count).ClearContents

    Alert.Activate
    DoEvents
    For Each oShape In Alert.Shapes
    If Not Application.Intersect(oShape.TopLeftCell, Alert.Rows("15:" & Alert.Rows.count)) Is Nothing Then
            oShape.Delete
        End If
    Next

    Dim i As Integer, sht As String
    DoEvents
        For i = 0 To ListBox1.ListCount - 1
            If ListBox1.Selected(i) = True Then
                sht = ListBox1.List(i)
            End If
        Next i

        Application.EnableEvents = False

    Sheets(sht).Range("A15:L345").Copy Alert.Range("A15")
    Alert.Range("C1:C2").Value = Sheets(sht).Range("C1:C2").Value
    Alert.Range("H2:L3").Value = Sheets(sht).Range("H2:L3").Value
    Alert.Range("H5:L10").Value = Sheets(sht).Range("H5:L10").Value

    Alert.Range("B34") = Sheets(sht).Name

    Sheets(sht).Delete

     Call rename

     Application.Calculation = xlCalculationAutomatic

    Application.ScreenUpdating = True: Application.DisplayAlerts = True: 
    Application.AskToUpdateLinks = True: Application.EnableEvents = True

    End Sub


    Sub rename()

    Dim ws As Worksheet

    Application.ScreenUpdating = False: Application.DisplayAlerts = False: Application.AskToUpdateLinks = False: Application.EnableEvents = False 'For less lag


    Alert.Name = Alert.Range("B34")
    Alert.Range("B34") = ""

    DoEvents
With Alert.Range("L5:L10")
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
 End With
DoEvents
With Alert.Range("L2:L3")
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
 End With

    Application.ScreenUpdating = True: Application.DisplayAlerts = True: 
    Application.AskToUpdateLinks = True: Application.EnableEvents = True

    End Sub

---

这是一个简单版本的代码，它似乎可以阻止excel崩溃

Private Sub CommandButton1_Click()


Dim sheet_name As String
Dim oShape As Shape

Alert.Rows("15:" & Alert.Rows.count).ClearContents

Alert.Activate
DoEvents
For Each oShape In Alert.Shapes
    If Not Application.Intersect(oShape.TopLeftCell, Alert.Rows("15:" & Alert.Rows.count)) Is Nothing Then
        oShape.Delete
    End If
Next

Dim i As Integer, sht As String
DoEvents
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) = True Then
            sht = ListBox1.List(i)
        End If
    Next i

    Application.EnableEvents = False

Sheets(sht).Range("A15:L345").Copy Alert.Range("A15")
Alert.Range("C1:C2").Value = Sheets(sht).Range("C1:C2").Value
Alert.Range("H2:L3").Value = Sheets(sht).Range("H2:L3").Value
Alert.Range("H5:L10").Value = Sheets(sht).Range("H5:L10").Value


Application.EnableEvents = False

Sheets(sht).Delete
Alert.Name = sht

Application.EnableEvents = False

DoEvents
With Alert.Range("L5:L10")
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
 End With
DoEvents
With Alert.Range("L2:L3")
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
 End With

Application.EnableEvents = True

End Sub

---

这是一个简单版本的代码，它似乎可以阻止excel崩溃

Private Sub CommandButton1_Click()


Dim sheet_name As String
Dim oShape As Shape

Alert.Rows("15:" & Alert.Rows.count).ClearContents

Alert.Activate
DoEvents
For Each oShape In Alert.Shapes
    If Not Application.Intersect(oShape.TopLeftCell, Alert.Rows("15:" & Alert.Rows.count)) Is Nothing Then
        oShape.Delete
    End If
Next

Dim i As Integer, sht As String
DoEvents
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) = True Then
            sht = ListBox1.List(i)
        End If
    Next i

    Application.EnableEvents = False

Sheets(sht).Range("A15:L345").Copy Alert.Range("A15")
Alert.Range("C1:C2").Value = Sheets(sht).Range("C1:C2").Value
Alert.Range("H2:L3").Value = Sheets(sht).Range("H2:L3").Value
Alert.Range("H5:L10").Value = Sheets(sht).Range("H5:L10").Value


Application.EnableEvents = False

Sheets(sht).Delete
Alert.Name = sht

Application.EnableEvents = False

DoEvents
With Alert.Range("L5:L10")
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
 End With
DoEvents
With Alert.Range("L2:L3")
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
 End With

Application.EnableEvents = True

End Sub

---

摆脱

。选择
将是第一步：。这会产生不必要的重载，并使您的代码变慢和不可靠。set application.calculation=manual，application.ScreenUpdate=false，然后在最后将其重新启用。@Canute我在这里做了
Private Sub CommandButton1\u Click（）Application.ScreenUpdate=False:Application.DisplayAlerts=False:Application.AskToUpdateLinks=False:Application.EnableEvents=False'用于延迟较小的应用程序。Calculation=xlCalculationManual
最后是
Application.Calculation=xlCalculationAutomatic Application.ScreenUpdate=True:Application.DisplayAlerts=True:Application.AskToUpdateLinks=True:Application.EnableEvents=True
但它仍然crash@Peh你是说如果我更改Rename sub上的选择，它可能会停止崩溃？如果这种情况在大多数情况下发生
这意味着代码本身没有明显的错误，但是Excel需要更多可用的资源。为了节省资源，请按照@PEH的建议进行操作。无用的选择会消耗资源。从
工作表（sht）开始。请激活
。使用
Dim sh作为工作表
，然后
Set sh=Sheets（sht）
。然后使用
sh.Range（“A15:L345”）.Copy Alert.Range（“A15”）
而不是
ActiveSheet.Range（“A15:L345”）.Copy Alert.Range（“A15”）
等等。在另一个子项中执行类似操作：
带范围（“L5:L10”）
而不是
带选择
等等…摆脱
。选择
将是第一步：。这会产生不必要的重载，并使您的代码变慢和不可靠。set application.calculation=manual，application.ScreenUpdate=false，然后在最后将其重新启用。@Canute我在这里做了
Private Sub CommandButton1\u Click（）Application.ScreenUpdate=False:Application.DisplayAlerts=False:Application.AskToUpdateLinks=False:Application.EnableEvents=False'用于延迟较小的应用程序。Calculation=xlCalculationManual
最后是
Application.Calculation=xlCalculationAutomatic Application.ScreenUpdate=True:Application.DisplayAlerts=True:Application.AskToUpdateLinks=True:Application.EnableEvents=True
但它仍然crash@Peh你是说如果我更改Rename sub上的选择，它可能会停止崩溃？如果这种情况在大多数情况下发生
这意味着代码本身没有明显的错误，但是Excel需要更多可用的资源。为了节省资源，请按照@PEH的建议进行操作。无用的选择会消耗资源。从
工作表（sht）开始。请激活
。使用
Dim sh作为工作表
，然后
Set sh=Sheets（sht）
。然后使用
sh.Range（“A15:L345”）.Copy Alert.Range（“A15”）
而不是
ActiveSheet.Range（“A15:L345”）.Copy Alert.Range（“A15”）
等等。在另一个子项中执行类似操作：
使用范围（“L5:L10”）
而不是选择
等等……您还应该避免
。在Alert.Shapes
和
rename（）中为每个oShape激活
和
警报.Rows（“15:&Alert.Rows.count）
和
重命名（）
应该不需要
警报。激活
，并且该范围
和范围（“L5:L10”）
没有工作表。因此，不应使用带有警报的
。范围（“L5:L10”）
和带有选择的
。另外，
Alert.Range（“A1”）.Activate很可能不需要。不，
Rows（“15:”&Rows.count）
现在指的是
ActiveSheet
。始终指定工作表！它必须是
Alert.Rows（“15:&Alert.Rows.count）
切勿在没有工作表的情况下使用任何
范围
、
单元格
、
行
或
列
对象。范围为（“L5:L10”）
的
仍然缺少图纸名称！它应该是带有Alert.Range（“L5:L10”）的
我对这部分感到困惑
Alert.Activate DoEvents，如果不是应用程序的话，每个oShape的形状都应该是。Intersect（oShape.TopLeftCell，Rows（“15:&Rows.count））如果excel文件仍为空，则删除结束crashing@Fah如果需要，可以在每个循环之前使用DoEvents，但它会减慢代码的执行速度。最亲切的问候（你为什么不接受答案？）你也应该避免
。激活
和
ActiveSheet
：
对于Alert.Shapes和
Alert.Rows（“15:”&Alert.Rows.count）中的每个oShape和
重命名（）
中的
警报。不需要激活
，并且此范围
具有范围(“L5:L10”）
没有工作表。因此：
带警报的范围（“L5:L10”）
和
带选择的范围（“L5:L10”）
也不应该使用。另外，
警报的范围（“A1”）。很可能不需要激活。不，
行（“15:”&Rows.count）
现在指的是
ActiveSheet
。请始终指定工作表！它必须是
警报的行（“15:“&Alert.Rows.count）
切勿使用任何
命令