VBAコードのためにワークブックが遅くてクラッシュしますか？とにかくこれを止める/これをスピードアップするには？

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

選択変更イベントコードでセルを選択すると、選択変更イベントが再度トリガされます。 Sheet Change Eventでセルの値を変更すると、同じイベントが再びトリガーされます。 バックグラウンドでは、イベントコードが複数回トリガされ、コード実行が遅くなります。

これを処理するには、Application.EnableEvents = Falseを使用して、イベントコードが再度トリガーされないようにする必要があります。 しかし、もう一度Application.EnableEvents = Trueでイベントを有効にすることを忘れないでください。