如何在代码运行时加速宏/隐藏屏幕答案

【问题标题】：How to speed up macros/hide screen while code is running如何在代码运行时加速宏/隐藏屏幕
【发布时间】：2016-01-15 16:42:19
【问题描述】：

如果找到匹配项，我有一系列宏可以格式化单个工作表并从硬编码数组中导入值。代码注释很好。宏按照它们列出的顺序被调用。我想就如何加快代码速度或隐藏工作表以使用户在宏运行时不会在屏幕上看到任何操作提出意见。非常感谢。

    Sub MacroA()
    '
    ' addcolumn Macro
    '

        Dim sht As Worksheet
        Dim LastRow As Long

        Set sht = ThisWorkbook.Worksheets("QC")

        LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row

       Application.EnableEvents = False
       Application.ScreenUpdating = False
       '~~~~~> error checking

                   If Sheet2.Range("A2").Value = "" Then
                'MsgBox " There are no QC samples on this run"
                Exit Sub
                End If

        Worksheets("QC").Select
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~copy down value from A2

        sht.Range("A2").Value2 = "HD200_QC"
        'copy QC name down
        Range("A2").Select
        Selection.Copy
        Range("A2:A" & LastRow).Select
        ActiveSheet.Paste
     '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        Columns(3).EntireColumn.Delete 'removes extra column for interpretation

        Columns("H:H").Select '\\add one column
        Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

        Columns("G:G").Select 'convert formulas to values
        Selection.Copy
        Columns("G:G").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        With sht

        .Range("A1").Value2 = "QC"
        .Range("G1").Value2 = "AAchange"
        .Range("H1").Value2 = "Standard"

         End With
     Application.EnableEvents = True
     Application.ScreenUpdating = True

    End Sub
Sub deleteIrrelevantColumns() 'delete all columns except for the ones with a certain name.

    Dim currentColumn As Integer
    Dim columnHeading As String

Application.EnableEvents = False
Application.ScreenUpdating = False
    'ActiveSheet.Columns("L").Delete

    For currentColumn = ActiveSheet.UsedRange.Columns.Count To 1 Step -1

        columnHeading = ActiveSheet.UsedRange.Cells(1, currentColumn).Value

        'CHECK WHETHER TO KEEP THE COLUMN
        Select Case columnHeading
            Case "QC", "gene", "exon", "cDNA", "AAchange", "%Alt", "Standard"
                'Do nothing
            Case Else
                'Delete if the cell doesn't contain these
                If InStr(1, _
                   ActiveSheet.UsedRange.Cells(1, currentColumn).Value, _
                   "Matreshkaper", vbBinaryCompare) = 0 Then

                    ActiveSheet.Columns(currentColumn).Delete

                End If
        End Select
    Next
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub



Sub PopulateStandard()
'PURPOSE: Filter on specific values


Dim rng As Range
Dim LastRow, i As Long
Dim GeneCheck As String
Dim vArr As Variant
Dim x
Dim y

'wsQC.Select
Worksheets("QC").Select

LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row

Application.EnableEvents = False
Application.ScreenUpdating = False


vArr = Array(Array("HD300_QCL861Q", "5"), _
Array("HD300_QCE746_E749del", "5"), _
Array("HD300_QCL858R", "5"), _
Array("HD300_QCT790M", "5"), _
Array("HD300_QCG719S", "5"), _
Array("HD200_QCV600E", "10.5"), _
Array("HD200_QCD816V", "10"), _
Array("HD200_QCE746_E749del", "2"), _
Array("HD200_QCL858R", "3"), _
Array("HD200_QCT790M", "1"), _
Array("HD200_QCG719S", "24.5"), _
Array("HD200_QCG13D", "15"), _
Array("HD200_QCG12D", "6"), _
Array("HD200_QCQ61K", "12.5"), _
Array("HD200_QCH1047R", "17.5"), _
Array("HD200_QCE545K", "9"))



For i = 2 To LastRow

GeneCheck = Right(Cells(i, 1).Value, 8) & Cells(i, 5).Value

'//Tell VBA to ignore an error and continue (ie if it can't find the value)
        On Error Resume Next

'//Assign the result of your calculation to a variable that VBA can query

    x = WorksheetFunction.VLookup(GeneCheck, vArr, 2, False)



     '//if Vlookup finds the value, then paste it into the required column
        If Err = 0 Then

    Cells(i, 6).Value = x
            Else

            End If

            '//resets to normal error handling
            On Error GoTo 0
Next


Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Sub MissingValues()

Dim zArr As Variant
Dim yArr As Variant

Dim LastRow As Long
Dim LastRow2 As Long
Dim sht As Worksheet

Set sht = ThisWorkbook.Worksheets("QC")

Application.EnableEvents = False
Application.ScreenUpdating = False

yArr = Array(Array("EGFR", "", "", "L861Q", "5"), _
       Array("EGFR", "", "", "KELRE745delinsK", "5"), _
       Array("EGFR", "", "", "L858R", "5"), _
       Array("EGFR", "", "", "T790M", "5"), _
       Array("EGFR", "", "", "G719S", "5"))

zArr = Array(Array("BRAF", "", "", "V600E", "10.5"), _
        Array("KIT", "", "", "D816V", "10"), _
        Array("EGFR", "", "", "KELRE745delinsK", "2"), _
        Array("EGFR", "", "", "L858R", "3"), _
        Array("EGFR", "", "", "T790M", "1"), _
        Array("EGFR", "", "", "G719S", "24.5"), _
        Array("KRAS", "", "", "G13D", "15"), _
        Array("KRAS", "", "", "G12D", "6"), _
        Array("NRAS", "", "", "Q61K", "12.5"), _
        Array("PIK3CA", "", "", "H1047R", "17.5"), _
        Array("PIK3CA", "", "", "E545K", "9"))

'Ctrl + Shift + End
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row

If InStr(1, ActiveSheet.Range("A2").Value, "HD200") > 0 Then


    Sheets("QC").Select
        Worksheets("QC").Range("B" & LastRow + 2 & ":F" & LastRow + 12).Value = Application.Index(zArr, 0)

ElseIf InStr(1, ActiveSheet.Range("A2").Value, "HD300") > 0 Then


    Sheets("QC").Select
        Worksheets("QC").Range("B" & LastRow + 2 & ":F" & LastRow + 6).Value = Application.Index(yArr, 0)

End If

LastRow2 = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row

'MsgBox (LastRow2)

Columns("B:G").Select
    ActiveSheet.Range("$A$1:$G$" & LastRow2).RemoveDuplicates Columns:=Array(2, 5, 6), _
        Header:=xlYes
    Range("A1").Select


With Worksheets("QC")
        'lRow = .Range("A" & Rows.Count).End(xlUp).Row
        .Cells(LastRow + 1, 1).Value = "Removed Low Alts."
End With

    Columns("A:A").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Columns("A:G").EntireColumn.AutoFit
    Range("A1").Select


    Range("A1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    ActiveWorkbook.Worksheets("QC").Sort.SortFields.clear
    ActiveWorkbook.Worksheets("QC").Sort.SortFields.Add Key:=Range("F2:F" & LastRow), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("QC").Sort
        .SetRange Range("A1:G" & LastRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With



    ' Adds a grid around the data
LastRow2 = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row
    Range("A2:G" & LastRow2).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .colorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .colorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .colorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .colorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .colorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .colorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    '~~~~> add yellow color
    Range("F2:G" & LastRow2).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 12514808
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With

    '~~~~> make font red
     Range("F2:F" & LastRow2).Select
    With Selection.Font
        .Color = -16777024
        .TintAndShade = 0
    End With


    Range("A1").Select

Application.EnableEvents = True
Application.ScreenUpdating = True

End Sub


Sub Filter()


'PURPOSE: Filter on specific values


Dim rng As Range
Dim LastRow, i As Long
Dim GeneCheck As String
Dim vArr As Variant
Dim x
Dim y
Dim FilterField As Variant
'wsQC.Select
Worksheets("QC").Select

LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row

Application.EnableEvents = False
Application.ScreenUpdating = False

Set rng = ActiveSheet.Range("A1:AC" & LastRow)
FilterField = WorksheetFunction.Match("AAchange", rng.Rows(1), 0)

'Turn on filter if not already turned on
 'If ActiveSheet.AutoFilterMode = False Then rng.AutoFilter

      If InStr(1, ActiveSheet.Range("A2").Value, "HD200") > 0 Then
     rng.AutoFilter
'Filter Specific Countries
    rng.AutoFilter Field:=FilterField, Criteria1:=Array( _
    "V600E", "KELRE745delinsK", "T790M", "G719S", "D816V", "G13D", "G12D", "Q61K", "H1047R", "L858R", "E545K"), Operator:=xlFilterValues

     Else 'If InStr(1, ActiveSheet.Range("A2").Value, "HD300") > 0 Then

     rng.AutoFilter
      rng.AutoFilter Field:=FilterField, Criteria1:=Array( _
      "L861Q", "KELRE745delinsK", "L858R", "T790M", "G719S"), Operator:=xlFilterValues

     End If

'End If

 '~~~> format top row.
 Range("A1").Select 'format top row
    Range(Selection, Selection.End(xlToRight)).Select
    With Selection.Interior
        .Pattern = xlPatternLinearGradient
        .Gradient.Degree = 90
        .Gradient.ColorStops.clear
    End With
    With Selection.Interior.Gradient.ColorStops.Add(0)
        .Color = 11298378
        .TintAndShade = 0
    End With
    With Selection.Interior.Gradient.ColorStops.Add(1)
        .Color = 5384228
        .TintAndShade = 0
    End With
    With Selection.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With



Application.EnableEvents = True
Application.ScreenUpdating = True


End Sub

【问题讨论】：

在宏的开头添加'Application.ScreenUpdating = False'。在宏的末尾添加“Application.ScreenUpdating = True”。请注意，如果宏在结束之前崩溃，您的屏幕将被冻结而无需额外的手动干预。如果要使用此方法，则必须添加适当的错误处理，以确保打开屏幕更新。
抱歉，我已经有了“Application.ScreenUpdating = False”。还有什么可以做的吗？谢谢
这可能会有所帮助：stackoverflow.com/questions/23602997/…
如果你已经这样做了[我没有阅读代码，我承认，因为那里有太多东西可以轻松完成]，用户不应该在运行过程中体验到任何变化宏。您确定该命令按预期工作吗？此外 - 您必须添加错误处理，以便如果弹出错误，代码会跳转到说明屏幕更新已恢复的部分。

标签： excel vba

【解决方案1】：

添加边框的这段代码可以加快速度。

LastRow2 = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row
    Range("A2:G" & LastRow2).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .colorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .colorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .colorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .colorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .colorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .colorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With

可以用这个代替。编辑您的代码以删除选择。

Dim sht As Worksheet
Dim LastRow As Long

Set sht = ThisWorkbook.Worksheets("QC")
Dim rng As Range

LastRow2 = sht.Cells(sht.Rows.Count, "B").End(xlUp).Row
Set rng = sht.Range("A2:G" & LastRow2)

With rng.Borders
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = xlAutomatic
End With

【讨论】：