vba - 非常非常慢的 Excel 宏

Question

我正在尝试通过转储数据池并重新格式化来自动化我每天在工作中必须执行的过程。我已经为此工作了很长一段时间，我认为我会去的最后一个地方是在论坛上寻求帮助。我已经进行了一些研究，并在我的宏中包含了尽可能多的建议。当我第一次创建宏时，我有所有的“选择”，它运行得很快。当我出于试用目的而继续运行它时，它变得越来越慢。现在需要 2 分钟或更长时间才能完成，并且在第 5 秒内停止响应，然后在 2-3 分钟后完成。

这样做的目的是重新格式化正在查看的工作表的信息，并根据日期创建工作表来确定信息的优先级。所有日期都链接到名为“Hot Sheet”的工作表，但我创建了一个新工作表，然后切换公式引用，因此 Excel 本身不会过度工作。我是新手，自学成才，所以请放轻松。

PS:当我保存文件时，它现在提示我说:“隐私警告:此文档包含宏、ActiveX 控件、XML 扩展包信息或 Web 组件。这些可能包括文档检查器无法删除的个人信息。”

代码:

ActiveSheet.Name = "Sheet1"
Columns("A:A").Select
Range("A4").Activate
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
    Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
    :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), TrailingMinusNumbers:= _
    True

Rows("1:3").Insert Shift:=xlDown
Range("A1:T1").Select
With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
End With
Range("A1:T1").Merge
Range("A1:T1").FormulaR1C1 = "ASCP Planner Overview Report"
Range("A4").FormulaR1C1 = "Input Perameters"
Rows("5:37").ClearContents
Range("B4").ClearContents
Range("B5").FormulaR1C1 = "Instance Name"
Range("B6").FormulaR1C1 = "MRP Plan Name"
Range("B7").FormulaR1C1 = "Organization Code"
Range("B8").FormulaR1C1 = "Bucket Type"
Range("B9").FormulaR1C1 = "Report Type"
Range("B10").FormulaR1C1 = "Planner"
Range("B11").FormulaR1C1 = "Planner user name"
Range("B12").FormulaR1C1 = "Planner Lookup"
Range("B13").FormulaR1C1 = "Supplier"
Range("B14").FormulaR1C1 = "SC Total"
Range("B15").FormulaR1C1 = "Make / Buy"
Range("B16").FormulaR1C1 = "Net Shortage Only"
Range("B17").FormulaR1C1 = "Shortage Cutoff Date"
Range(Selection, Selection.End(xlToRight)).Select
Range("A40:F40").Cut Destination:=Range("E13:J13")
Rows("43:61").Delete Shift:=xlUp

On Error Resume Next
With Application
.ScreenUpdating = False
.EnableEvents = False
PrevCalc = .Calculation
.Calculation = xlCalculationManual
End With
Columns("A:A").ColumnWidth = 11
Range("T41").FormulaR1C1 = "Page 1"
 Range("E50").FormulaR1C1 = "=R[-5]C[-2]"
Range("E50").AutoFill Destination:=Range("E50:T50"), Type:=xlFillDefault
Range("B43").CutCopyMode = False
Range("F49").FormulaR1C1 = "=R[-6]C[-2]&R[-6]C[-1]&R[-6]C&R[-6]C[1]"
Range("F49").Copy
Range("F49").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Range("E50:T50").Copy
Range("E50:T50").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
Rows("43:48").ClearContents
Range("A43").FormulaR1C1 = "ORG"
Range("A44").FormulaR1C1 = "Planner"
Range("A45").FormulaR1C1 = "Sourcing Rule"
Range("A46").FormulaR1C1 = "OH Qty-Insp"
Range("A47").FormulaR1C1 = "Negative"
Range("A48").FormulaR1C1 = "OH-Consign"
Range("B43").FormulaR1C1 = "Item Number"
Range("B44").FormulaR1C1 = "Make/Buy"
Range("B46").FormulaR1C1 = "OH Qty-Total"
Range("B47").FormulaR1C1 = "In trans Qty"
Range("B48").FormulaR1C1 = "LT (Post P)"

        Range("93:93,95:112,155:155,157:174,217:217,219:236,279:279,281:298,341:341,343:360,403:403    ,405:422").Delete Shift:=xlUp
Rows("351:351").Delete Shift:=xlUp
Rows("352:369").Delete Shift:=xlUp
Rows("394:394").Delete Shift:=xlUp
Rows("395:412").Delete Shift:=xlUp
Rows("437:437").Delete Shift:=xlUp
Rows("440:455").Delete Shift:=xlUp
Rows("439:439").Delete Shift:=xlUp
Rows("481:481").Delete Shift:=xlUp

Range("57:57,63:63,69:69,75:75,81:81,87:87").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("99:101").Insert Shift:=xlDown
Range("F101").FormulaR1C1 = "=R[-52]C"
Range("E102:T102").FormulaR1C1 = "=R[-52]C"
Range("E102:T102").Select
Range("109:109,115:115,121:121,127:127,133:133,139:139").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("151:153").Insert Shift:=xlDown
Range("F153").FormulaR1C1 = "=R[-52]C"
Range("E154:T154").FormulaR1C1 = "=R[-52]C"
Range("E154:T154").Select
Range("161:161,167:167,173:173,179:179,185:185,191:191").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("203:205").Insert Shift:=xlDown
Range("F205").FormulaR1C1 = "=R[-52]C"
Range("E206:T206").FormulaR1C1 = "=R[-52]C"
Range("E206:T206").Select
Range("213:213,219:219,225:225,231:231,237:237,243:243").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("255:257").Insert Shift:=xlDown
Range("F257").FormulaR1C1 = "=R[-52]C"
Range("E258:T258").FormulaR1C1 = "=R[-52]C"
Range("E258:T258").Select
Range("265:265,271:271,277:277,283:283,289:289,295:295").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("307:309").Insert Shift:=xlDown
Range("F309").FormulaR1C1 = "=R[-52]C"
Range("E310:T310").FormulaR1C1 = "=R[-52]C"
Range("E310:T310").Select
Range("317:317,323:323,329:329,335:335,341:341,347:347").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("359:361").Insert Shift:=xlDown
Range("F361").FormulaR1C1 = "=R[-52]C"
Range("E362:T362").FormulaR1C1 = "=R[-52]C"
Range("E362:T362").Select
Range("369:369,375:375,381:381,387:387,393:393,399:399").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("411:413").Insert Shift:=xlDown
Range("F413").FormulaR1C1 = "=R[-52]C"
Range("E414:T414").FormulaR1C1 = "=R[-52]C"
Range("421:421,427:427,433:433,439:439,445:445,451:451").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("463:465").Insert Shift:=xlDown
Range("F465").FormulaR1C1 = "=R[-52]C"
Range("E466:T466").FormulaR1C1 = "=R[-52]C"
Range("473:473,479:479,485:485,491:491,497:497,503:503").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows("515:517").Insert Shift:=xlDown
Range("F517").FormulaR1C1 = "=R[-52]C"
Range("E518:T518").FormulaR1C1 = "=R[-52]C"
Rows("519:519").Delete Shift:=xlUp
Range("525:525,531:531,537:537,543:543,549:549,555:555").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = PrevCalc
End With

On Error Resume Next

Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Cells.Select
Range("C562").Activate
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, _
    Formula1:="=0"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font
    .Color = -16383844
    .TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
    .PatternColorIndex = xlAutomatic
    .Color = 13551615
    .TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Range("A50").Select
    Union(Range( _
    "B291,B298,B305,B315,B322,B329,B336,B343,B350,B357,B367,B374,B381,B388,B395,B402,B409,B419,B426,B55,B62,B69,B76,B83,B90,B97,B107,B114,B121,B128,B135,B142" _
    ), Range( _
    "B149,B159,B166,B173,B180,B187,B194,B201,B211,B218,B225,B232,B239,B246,B253,B263,B270,B277,B284" _
    )).Select
Range("B426").Activate
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _
    Formula1:="=0"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font
    .Color = -16752384
    .TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
    .PatternColorIndex = xlAutomatic
    .Color = 13561798
    .TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Range("A401").Select
Range("A51").Select

Application.DisplayAlerts = False
On Error Resume Next
Sheets("Sheet1").Copy Before:=Sheets(1)
ActiveSheet.Select
Sheets("View1").Delete
ActiveSheet.Name = "View1"
Sheets("Hot Sheet").Select
Cells.Select
ActiveSheet.Range("$A$1:$D$524").AutoFilter Field:=4
ActiveSheet.Range("$A$1:$D$524").AutoFilter Field:=1
Selection.Replace What:="View2", Replacement:="View1", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
Sheets("View1").Copy Before:=Sheets(1)
Sheets("View1 (2)").Select
Sheets("View2").Delete
Sheets("View1 (2)").Name = "View2"
Sheets("Hot Sheet").Select
Cells.Select
Selection.Replace What:="View1", Replacement:="View2", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
ActiveSheet.Range("$A$1:$D$524").AutoFilter Field:=1, Criteria1:=Array( _
"NA:ASH", "NA:DLM", "NA:FOR", "NA:FRK", "NA:LRS", "NA:MON", "NA:NWK", "NA:YRB", _
"NA:YRK"), Operator:=xlFilterValues
Range("A1").Select
Sheets("Sheet1").Delete
Application.EnableEvents = True
End Sub

Answer 1

尝试关闭屏幕更新以释放系统资源。您的宏可能还有其他问题，但您应该注意到性能的显着提高。

在宏的开头添加:

Application.ScreenUpdating = False

最后(在“End Sub”之前)添加:

Application.ScreenUpdating = True

我希望这有帮助。