是否有更快/更有效的方法来执行抓取和整理代码？ （抓取并收集具体数据）

Question

我有一张excel表，它使用宏来按时间顺序对项目的截止日期进行排序。然后，此工作表使用单独的宏来检查＆＃34;小时＆＃34;中是否有值。列（在此项目上花费的信号时间）。如果有值，则代码将提取数据并将这些实例整理为有序格式 - 然后可以将其作为每日时间表提交。它可能看起来非常混乱，但我是新的所以请理解这一点。

我相信这段代码也可能是excel运作不顺畅的原因--I.E。带状图标是灰色的，直到我将鼠标悬停在它们上面并且单元格选择可能会滞后（我必须在监视器屏幕周围移动Excel窗口以刷新并在运行以下代码后查看新值。）

任何评论请不要退缩。

请点击此链接查看完整文件。 WORKBREAKDOWN STRUCTURE

Public CalcState As Long
Public EventState As Boolean
Public PageBreakState As Boolean

Sub OptimizeCode_Begin()

Application.ScreenUpdating = False

EventState = Application.EnableEvents
Application.EnableEvents = False

CalcState = Application.Calculation
Application.Calculation = xlCalculationManual

PageBreakState = ActiveSheet.DisplayPageBreaks
ActiveSheet.DisplayPageBreaks = False

End Sub

Sub Timesheet()

    Dim SrchRng As Range
    Dim PastRng As Range
    Dim Laststp As Range
    Dim cel As Range
    Dim AdSt As Range
    Dim refe As Range


    Dim Hours As Long

    Call OptimizeCode_Begin


    Set SrchRng = Range("K4:K400")
    For Each cel In SrchRng
        If cel.Value <> "" Then

        'Setting up data cells to copy to temporary range
        Set PastRng = Range("L1")
        PastRng.Copy
        cel.Offset(, 1) = PastRng

        'Copy Proj number to temp range
        Set PastRng = cel.Offset(, -10)
        PastRng.Copy
        cel.Offset(, 2) = PastRng

        'Copy Proj name into temp range
        Set PastRng = cel.Offset(, -9)
        PastRng.Copy
        cel.Offset(, 3) = PastRng

        'Copy Activity into temp range
        Set PastRng = cel.Offset(, -6)
        PastRng.Copy
        cel.Offset(, 4) = PastRng


        'Copy cell x1 to right and paste in order in column S
        Set PastRng = cel.Offset(, 1)
        PastRng.Copy
        Range("S" & Rows.Count).End(xlUp).Offset(1) = PastRng

        'Copy cell x2 to right and paste in order in column T
        Set PastRng = cel.Offset(, 2)
        PastRng.Copy
        Range("T" & Rows.Count).End(xlUp).Offset(1) = PastRng

        'Copy cell x3 to right and paste in order in column U
        Set PastRng = cel.Offset(, 3)
        PastRng.Copy
        Range("U" & Rows.Count).End(xlUp).Offset(1) = PastRng

        'Copy cell x3 to right and paste in order in column V
        Set PastRng = cel.Offset(, 4)
        PastRng.Copy
        Range("V" & Rows.Count).End(xlUp).Offset(1) = PastRng

        'Copy hour to column X
        Set PastRng = cel
        PastRng.Copy
        Range("X" & Rows.Count).End(xlUp).Offset(1) = PastRng

        End If

        Next cel

        'Clear temporary sheet
        Range("L4:O200").Clear

    'do the same for above but now for the "Add Hour" column
    Set SrchRng = Range("J4:J400")
    For Each cel In SrchRng

    If cel.Value <> "" Then

        'Setting up data cells to copy onto
        Set PastRng = Range("L1")
        PastRng.Copy
        cel.Offset(, 2) = PastRng

        'Copy Proj number into temp range
        Set PastRng = cel.Offset(, -9)
        PastRng.Copy
        cel.Offset(, 3) = PastRng

        'Copy Proj name into copy temp range
        Set PastRng = cel.Offset(, -8)
        PastRng.Copy
        cel.Offset(, 4) = PastRng

        'Copy Activity into copy temp range
        Set PastRng = cel.Offset(, -5)
        PastRng.Copy
        cel.Offset(, 5) = PastRng


        'Copy cell x2 to right and paste in order in column S
        Set PastRng = cel.Offset(, 2)
        PastRng.Copy
        Range("S" & Rows.Count).End(xlUp).Offset(1) = PastRng

        'Copy cell x3 to right and paste in order in column T
        Set PastRng = cel.Offset(, 3)
        PastRng.Copy
        Range("T" & Rows.Count).End(xlUp).Offset(1) = PastRng

        'Copy cell x4 to right and paste in order in column U
        Set PastRng = cel.Offset(, 4)
        PastRng.Copy
        Range("U" & Rows.Count).End(xlUp).Offset(1) = PastRng

        'Copy cell x5 to right and paste in order in column V
        Set PastRng = cel.Offset(, 5)
        PastRng.Copy
        Range("V" & Rows.Count).End(xlUp).Offset(1) = PastRng

        'Copy hour to column X

    End If

    Set refe = Range("X" & Rows.Count).End(xlUp).Offset(1, -1)

        If refe <> "" Then
            Set PastRng = cel
            PastRng.Copy
            Range("W" & Rows.Count).End(xlUp).Offset(1) = PastRng

            Else
            Set PastRng = cel
            PastRng.Copy
            Range("X" & Rows.Count).End(xlUp).Offset(1, -1) = PastRng

        End If

    Next cel

    'clear temporary range
    Range("L4:O200").Clear

    Call OptimizeCode_End


MsgBox "Complete!"


End Sub

Sub OptimizeCode_End()

ActiveSheet.DisplayPageBreaks = PageBreakState
Application.Calculation = CalcState
Application.EnableEvents = EventState
Application.ScreenUpdating = True

End Sub

Answer 1

首先要尝试添加

DoEvents

循环内部。它不会让它变得更快，但你不会得到冻结效果。