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

问题描述 投票:0回答:1

我有一个简单的代码,将1张表的所有内容复制并粘贴到另一张表中,大多数情况下,代码完成运行后,excel文件会关闭并再次打开(但没有任何信息)。

这段代码是由用户表单中的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

我如何防止它崩溃?

excel vba
1个回答
1
投票

我建议使用 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

1
投票

这是一个简单的代码版本,它似乎阻止了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
© www.soinside.com 2019 - 2024. All rights reserved.