ОБНОВЛЕНИЕ - см. Редактировать сводку: Новое в VBA: код работает медленно и перед завершением переходит в Excel «Не отвечает»

Question

Этот код берет необработанные данные и помещает их в шаблон отчета, где он преобразуется с использованием операторов 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

Answer 1

Не используйте select в диапазоне, это чрезвычайно дорого, вот пример, чтобы избежать этого:

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

Становится:

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

Примечание. Удалите. Выберите и Выделение.

Возможно, я также отключил бы вычисление в начале кода и снова включил в конце.

Если вы решите это сделать, то вам нужно будет сделать руководство Рассчитайте после ввода формулы, как здесь:

    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