Question

我的工作表中有以下代码。该代码导致电子表格工作缓慢且崩溃，并且打开也需要很长时间。我是VBA的新手，可能无法正确编码。是否有更好的方法来构建我的代码以防止这种情况发生？

Option Explicit
Option Compare Text

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo Message
ActiveSheet.DisplayPageBreaks = False
 If Target.Address = "$K$3" Then
    If Range("A" & Rows.Count).End(xlUp).Row < 5 Then
    Range("A5").Select
    Else
    Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Select
    End If
    End If

    If Target.Address = "$I$3" Then
    If Range("A" & Rows.Count).End(xlUp).Row < 5 Then
    Range("A5").Select
    Else
    Range("A9").Select
    End If
    End If


     If Target.Address = "$N$2" Then
    If Range("A" & Rows.Count).End(xlUp).Row < 5 Then
        Range("A5").Select
    Else
        Range("A7").Select
    End If
    End If


       'Clear Search Box
    If Target.Address = "$N$3:$O$3" Then
    Target.Value = ""
    End If




Exit Sub

Message:
Application.DisplayAlerts = False
Exit Sub

End Sub


Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo Message
On Error Resume Next

ActiveSheet.DisplayPageBreaks = False



'Insert Depot Memo Data for user
 Dim oCell As Range, targetCell As Range
    Dim ws2 As Worksheet
    On Error GoTo Message
    If Not Intersect(Target, Range("B:B")) Is Nothing Then ' <-- run this code only if a value in column I has changed
        If Not GetWb("Depot Memo", ws2) Then Exit Sub

        With ws2
            For Each targetCell In Target
                Set oCell = .Range("J1", .Cells(.Rows.Count, "J").End(xlUp)).Find(What:=targetCell.Value, LookIn:=xlValues, LookAt:=xlWhole)
                If Not oCell Is Nothing Then
                    Application.EnableEvents = False

                    'Set Format of cell
                    targetCell.Font.Name = "Arial"
                    targetCell.Font.Size = "10"

                    With targetCell.Borders(xlEdgeLeft)
                    .LineStyle = xlContinuous
                    .Color = RGB(192, 0, 0)
                    .Weight = xlMedium
                    End With

                    With targetCell.Borders(xlEdgeRight)
                    .LineStyle = xlContinuous
                    .Color = RGB(192, 0, 0)
                    .Weight = xlMedium
                    End With

                    With targetCell.Borders(xlEdgeTop)
                    .LineStyle = xlContinuous
                    .Color = RGB(191, 191, 191)
                    .Weight = xlThin
                    End With

                    With targetCell.Borders(xlEdgeBottom)
                    .LineStyle = xlContinuous
                    .Color = RGB(191, 191, 191)
                    .Weight = xlThin
                    End With


                    targetCell.Offset(0, -1).Value = Now()
                    targetCell.Offset(0, 1).Value = oCell.Offset(0, 1)
                     targetCell.Offset(0, 2).Value = oCell.Offset(0, -2)
                     targetCell.Offset(0, 3).Value = oCell.Offset(0, -7)
                    Application.EnableEvents = True
                End If
            Next
        End With
    End If





 'Prompt missed on sale
    If Not Intersect(Target, Range("N:N")) Is Nothing And ActiveCell.Value = "Issue Complete" Then
    If Target.Cells.Count < 8 Then
    Dim MSG1 As Variant

    MSG1 = MsgBox("Did Item Miss On-Sale?", vbYesNo, "Feedback")
    If MSG1 = vbYes Then
    Range("O" & ActiveCell.Row).Value = "Yes"
    Else
    Range("O" & ActiveCell.Row).Value = "No"
    End If

    Range("P" & ActiveCell.Row).Value = Date - Range("A" & ActiveCell.Row).Value

    End If
    End If



 If Not Intersect(Target, Range("D" & ActiveCell.Row)) Is Nothing And Target.Value <> "" Then
 Call PhoneBook2
 End If






'Send Email - Receipt of Issue

Application.ScreenUpdating = False
Application.DisplayAlerts = False
If Not Intersect(Target, Range("N:N")) Is Nothing And ActiveCell.Value <> "" Then
If Target.Cells.Count < 4 Then

Call SendEmail0

End If
End If



'Send Email - Status Change

Application.ScreenUpdating = False
Application.DisplayAlerts = False
If Not Intersect(Target, Range("N:N")) Is Nothing And ActiveCell.Value <> "" Then
If Target.Cells.Count < 4 Then

Call SendEmail

End If
End If



Application.ScreenUpdating = True
Application.DisplayAlerts = True







Exit Sub



Message:
Application.DisplayAlerts = False
Exit Sub

End Sub


Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
If ActiveCell.Value = "(Turn Off Emails)" Then
UserForm1.Show
End If

End Sub






Function GetWb(wbNameLike As String, WS As Worksheet) As Boolean
    Dim Wb As Workbook
    For Each Wb In Workbooks
        If Wb.Name Like "*" & wbNameLike & "*" Then '<-- check if workbook name contains "Depot Memo"
            Set WS = Wb.Worksheets(1)
            Exit For
        End If
    Next
    GetWb = Not WS Is Nothing
End Function

Answer 1

在选择更改事件代码中选择单元格时，将再次触发选择更改事件。更改工作表更改事件中的单元格值时会发生同样的事情，同一事件再次被触发。因此在后台事件代码被多次触发，这使代码执行变慢。

要处理此问题，您应该使用Application.EnableEvents = False来避免再次触发事件代码。但请记住通过Application.EnableEvents = True再次启用事件

由于VBA代码，工作簿缓慢而崩溃？无论如何要阻止这个/加速这个？

1 个答案: