在表格之间复制行

Question

我使用下面列出的代码在工作表之间复制行，在Sheet1中运行250行并在Sheet2中运行120行需要大约15秒，我认为这是很长时间。完成写入sheet4后，我需要在sh1和sh4之间切换，以显示Sheet4数据。写入sheet4后，除非我退出并重新加载工作簿，否则我无法突出显示单元格。请帮忙

Sub CompareWorksheets(ws1 As Worksheet, ws2 As Worksheet)
    Dim r As Long, c As Integer
    Dim h, pasteRowIndex As Integer
    Dim lr1 As Long, lr2 As Long, lc1 As Integer, lc2 As Integer
    Dim maxR As Long, maxC As Integer, cf1 As String, cf2 As String
    Dim rptWB As Workbook, DiffCount As Long
    Dim strTemp As String
    Application.ScreenUpdating = False

    Application.DisplayAlerts = True

    With ws1.UsedRange
        lr1 = .Rows.Count
        lc1 = .Columns.Count
    End With
    With ws2.UsedRange
        lr2 = .Rows.Count
        lc2 = .Columns.Count
    End With
    h = 0
    pasteRowIndex = 2
    maxR = lr1
    maxC = lc1
    If maxR < lr2 Then maxR = lr2
    If maxC < lc2 Then maxC = lc2
    DiffCount = 0
    'delete rows with patients older than 80 sheet2
    For c = 2 To lr2
        If ws2.Cells(c, "D") > 80 Then
            ws2.Cells(c, "D").EntireRow.Delete
        End If
    Next c

    'delete rows with patients older than 80 sheet1
    For c = lr1 To 2 Step -1
        If ws1.Cells(c, "D") > 80 Then
            ws1.Cells(c, "D").EntireRow.Delete
        End If
    Next c

    For c = 2 To lr2  'Sheet 2 loop
        Application.StatusBar = "Comparing cells " & Format(c / maxC, "0 %") & "..."
        For r = 2 To lr1 'Sheet 1 loop
            cf1 = ""
            cf2 = ""
            On Error Resume Next
            cf1 = ws1.Cells(r, 1).FormulaLocal
            cf2 = ws2.Cells(c, 1).FormulaLocal
            On Error GoTo 0
            If cf1 = cf2 Then
                h = h + 1
                strTemp = "A" & r & ":" & "L" & r
                Sheets("Sheet1").Range("A" & r).EntireRow.Copy Destination:=Sheets("Sheet4").Range("A" & Rows.Count).End(xlUp).Offset(1)
                Exit For
            End If
        Next r
    Next c
    Application.ScreenUpdating = True

End Sub