时间戳

首页 > 解决方案 > 更新 - 请参阅编辑摘要：VBA 新手：代码很慢，在完成之前进入 Excel“无响应”

excel - 更新 - 请参阅编辑摘要：VBA 新手：代码很慢，在完成之前进入 Excel“无响应”

问题描述

此代码获取原始数据并将其放入报告模板中，在该模板中使用 if then 语句和条件格式对其进行转换。数据是从在线资源下载的。导入的文件被移动到工作簿中。用户然后运行此宏以将导入的文件合并到报告模板中。

在添加 ActiveWorkbook.Save 行之前，此代码将只运行大约一半的时间。现在它一直运行，但速度很慢，并且在完成前会进入 Excel“无响应”几秒钟。有人可以帮我提高这段代码的效率吗？

Sub Refresh()
' Refresh Macro

' Checks the import data for accurate column headings, then refreshes the Standup Report with the new import data.  Keeps Board Status Entries

Dim ColumnOrder As Variant, ndx As Integer
Dim Found As Range, counter As Integer

Dim rTemplate As Worksheet, nImport As Worksheet
Set rTemplate = ThisWorkbook.Worksheets("Standup Report Template")

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual


On Error GoTo ErrHandler

'Move the "Standup Report Template" Worksheet to first position.
rTemplate.Move Before:=ActiveWorkbook.Sheets(1)

    'Order Columns correctly
    On Error Resume Next

    Set nImport = ThisWorkbook.Worksheets(2)

    nImport.Activate

    ColumnOrder = Array("Formatted ID", "Name", "Schedule State", "Blocked", "Plan Estimate", "At Risk", "Added")
    counter = 1

    For ndx = LBound(ColumnOrder) To UBound(ColumnOrder)
        Set Found = Rows("1:1").Find(ColumnOrder(ndx), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
        If Not Found Is Nothing Then
            If Found.Column <> counter Then
                Found.EntireColumn.Cut
                Columns(counter).Insert Shift:=xlToRight
                Application.CutCopyMode = False
            End If
        counter = counter + 1

        End If
    Next ndx


    'Check to make sure all columns are present
    On Error GoTo ErrHandler

    If Range("A1").Value = "Formatted ID" And Range("b1").Value = "Name" And Range("c1").Value = "Schedule State" And Range("d1").Value = "Blocked" And Range("e1").Value = "Plan Estimate" And Range("f1").Value = "At Risk" And Range("g1").Value = "Added" Then


        'insert formula to retain the current board state into column H of the new import file.

        Application.Calculation = xlAutomatic

        Range("H2").Formula = "=IF(ISERROR(MATCH(A2,'Standup Report Template'!B:B,0)),""NEW"",IF(ISBLANK(INDEX('Standup Report Template'!$B$1:$L$200,MATCH(A2,'Standup Report Template'!B:B,0),11)),""-"",INDEX('Standup Report Template'!$B$1:$L$200,MATCH(A2,'Standup Report Template'!B:B,0),11)))"
        With Sheets(2)
            .Range("H2").AutoFill .Range("H2:H" & .Cells(.Rows.Count, "A").End(xlUp).Row)
        End With

        Application.Calculation = xlManual

        'clear old data from report
        rTemplate.Activate
        Application.Goto Reference:="ClearEntries"
        Selection.ClearContents

        'Delete Header Row of New Import file
        nImport.Rows("1:1").Delete Shift:=xlUp

        'Assign (instead of copy paste) new import data to the report template
        rTemplate.Range("B4:H104").Value = nImport.Range("A1:G100").Value

        'Justify Text
        With Columns("B:B")
            .HorizontalAlignment = xlRight
            .VerticalAlignment = xlCenter
        End With

        With Columns("C:C")
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlCenter
        End With

        With Columns("D:H")
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With

        With Range("B3:H3")
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlBottom
        End With

        'Copy Paste Revised Board State
        nImport.Activate
        ActiveSheet.UsedRange.Columns("H:H").Copy


        rTemplate.Activate
        Range("L4").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False

        'Delete import file
        nImport.Delete

        rTemplate.Activate
        Range("L4").Select
        ActiveWindow.Zoom = 80

        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
        Application.Calculation = xlAutomatic


        MsgBox "New data has been imported. Please update the Board State as needed to finalize the report."



    Else:

        Rows("1:1").Select
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = 7765734
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With

        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        Application.Calculation = xlAutomatic


        MsgBox "The columns in your import table must be ordered as follows:" & vbCrLf & vbCrLf & "Formatted ID" & vbCrLf & "Name" & vbCrLf & "Schedule State" & vbCrLf & "Blocked" & vbCrLf & "Plan Estimate" & vbCrLf & "At Risk" & vbCrLf & "Added" & vbCrLf & vbCrLf & "Please make the appropriate changes to your import table and try again."




End If

Exit Sub

ErrHandler:

MsgBox "The Stand Up Report can't find your data.  Please move data into the workbook before trying again."




End Sub

标签： excelvba

解决方案

不要在范围上使用 select，它的成本非常高，这是一个避免它的示例：

    Columns("B:B").Select
    With Selection
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlCenter
    End With

变成：

    With Columns("B:B")
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlCenter
    End With

注意删除 .Select 和 Selection。

我可能还会在代码开始时关闭计算并在结束时重新打开。

如果您决定这样做，那么您需要在输入如下公式后进行手动计算：

    Range("H2").Formula = "=IF(ISERROR(MATCH(A2,'Standup Report Template'!B:B,0)),""NEW"",IF(ISBLANK(INDEX('Standup Report Template'!$B$1:$L$200,MATCH(A2,'Standup Report Template'!B:B,0),11)),""-"",INDEX('Standup Report Template'!$B$1:$L$200,MATCH(A2,'Standup Report Template'!B:B,0),11)))"
    With Sheets(2)
        .Range("H2").AutoFill .Range("H2:H" & .Cells(.Rows.Count, "A").End(xlUp).Row)
    End With
    Application.calculate

推荐阅读