如果子过程在同一个工作簿中运行两次，VBA速度会变慢吗？

我正在使用一个相当大的工作簿（50MB），我试图运行一个遍历表中所有单元格的过程（是的，我知道这很慢，但是不可避免），并删除一些格式并格式化其他格式。

事实certificate，将数据复制到新的工作簿并运行该过程出于任何原因要快得多。

但是，我试图用5个不同的表（我迄今为止只编码2）重复这个过程，如果我从同一个工作簿运行两次过程，我遇到了很多放缓。 放缓接近一个数量级。

如果我只运行一个程序，他们很容易在不到一分钟的时间内运行。 但是，当我跑他们两个，第二个只是CRAWLS（分开第二个需要~4秒）

有谁知道这可能是为什么？

我已经在下面包含了我的代码。

Sub FormatNewSchedules() StartTime = Timer Application.Calculation = xlManual Application.ScreenUpdating = False ' Set Up New Schedule Workbook Windows("New Schedule.xlsx").Activate Sheets("Sheet1").Select Sheets("Sheet1").Name = "Master Schedule" Sheets.Add After:=ActiveSheet Sheets("Sheet1").Select Sheets("Sheet1").Name = "Burn Schedule" Sheets.Add After:=ActiveSheet Sheets("Sheet2").Select Sheets("Sheet2").Name = "Weld Xray Schedule" Sheets.Add After:=ActiveSheet Sheets("Sheet3").Select Sheets("Sheet3").Name = "Press Schedule" Sheets.Add After:=ActiveSheet Sheets("Sheet4").Select Sheets("Sheet4").Name = "Pickle Schedule" ' Copy All Schedules ' Copy Master Schedule (Source) to New Schedule Call CopySource("Master Schedule", 10, "BE", 13, 1) ' Copy Burn Schedule (Source) to New Schedule Call CopySource("Burn Schedule", 9, "AA", 3, 1) ' Clean up Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic ' How much time? EndTime = Timer TimeCalc = EndTime - StartTime MsgBox Format(TimeCalc / 86400, "hh:mm:ss") Application.StatusBar = False End Sub 

这是我打电话多次的子程序：

 Sub CopySource(SourceName As String, FR As Integer, LC As String, _ Categories As Integer, NumHeaderRows As Integer) Dim i As Integer ' Copy Data from Master Schedule to New Schedule Dim LRSource As Integer LRSource = Workbooks("Master Schedule").Sheets(SourceName & " (Source)"). _ Cells(Rows.Count, 1).End(xlUp).Row Workbooks("Master Schedule").Sheets(SourceName & " (Source)"). _ Range("A" & FR & ":" & LC & LRSource).Copy Workbooks("New Schedule").Sheets(SourceName).Select Range("A1").Select Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False ' Table Dimensions Dim LastRow As Integer LastRow = Sheets(SourceName).Cells(Rows.Count, 1).End(xlUp).Row ' Delete every 3rd cell in Header Column For i = 0 To Categories - 1 Range(FirstColumn & "1:" & FirstColumn & NumHeaderRows). _ Offset(0, 2 * i + 2).Delete (xlShiftToLeft) Next i Dim RowCounter As Integer Dim FirstRow As Integer FirstRow = NumHeaderRows + 1 ' STEP 1: DELETE unnecessary cells For RowCounter = FirstRow To LastRow ' Update StatusBar PercentComplete = (RowCounter / (LastRow - FirstRow)) * 95 Application.StatusBar = PercentComplete & "% Complete; Row " & RowCounter & " of " & LastRow 'This row is NOT a Subtotal row If InStr(Range("A" & RowCounter).Value, "Total") = 0 _ And InStr(Range("B" & RowCounter).Value, "Total") = 0 _ And InStr(Range("C" & RowCounter).Value, "Total") = 0 Then ' Delete all RemHours + Date cells For i = 0 To Categories - 2 Range(FirstColumn & RowCounter).Offset(0, 2 * i).Delete (xlShiftToLeft) Next i Range(FirstColumn & RowCounter).Offset(0, (Categories - 1) * 2 + 1).Delete (xlShiftToLeft) 'This row IS a Subtotal row Else ' Delete all Remaining Standard Hours cells & RemHours + Date Total at end For i = 0 To Categories - 1 Range(FirstColumn & RowCounter).Offset(0, 2 * i + 1).Delete (xlShiftToLeft) Next i End If Next RowCounter ' STEP 2: FORMAT each cell based on value For RowCounter = FirstRow To LastRow ' Update Status Bar PercentComplete = (RowCounter / LastRow) * 5 + 95 Application.StatusBar = PercentComplete & "% Complete" ' Only apply to non-subtotal rows If InStr(Range("A" & RowCounter).Value, "Total") = 0 _ And InStr(Range("B" & RowCounter).Value, "Total") = 0 _ And InStr(Range("C" & RowCounter).Value, "Total") = 0 Then ' Apply formatting to each cell in the row For i = 0 To Categories - 1 Select Case Range(FirstColumn & RowCounter).Offset(0, 2 * i).Value ' Cell value is VALID DATE Case Is > 41275 ' Add Date Format and Borders Range(FirstColumn & RowCounter).Offset(0, 2 * i).NumberFormat = "m/d;@" With Range(FirstColumn & RowCounter).Offset(0, 2 * i).Borders .LineStyle = xlContinuous .Color = -10526881 .Weight = xlThin End With Range(FirstColumn & RowCounter).Offset(0, 2 * i).Interior.Color = 14540253 ' Cell value is INVALID DATE Case 10000 To 41275 ' Add Date Format and Borders Range(FirstColumn & RowCounter).Offset(0, 2 * i).NumberFormat = "m/d/yyyy" With Range(FirstColumn & RowCounter).Offset(0, 2 * i).Borders .LineStyle = xlContinuous .Color = -10526881 .Weight = xlThin End With Range(FirstColumn & RowCounter).Offset(0, 2 * i).Interior.Color = 6684927 Range(FirstColumn & RowCounter).Offset(0, 2 * i).Font.Color = -1 ' Cell has REMAINING HOURS Case Is > 0 ' Add Borders With Range(FirstColumn & RowCounter).Offset(0, 2 * i).Borders .LineStyle = xlContinuous .Color = -10526881 .Weight = xlThin End With ' Add Databars Range(FirstColumn & RowCounter).Offset(0, 2 * i).FormatConditions.AddDatabar With Range(FirstColumn & RowCounter).Offset(0, 2 * i).FormatConditions(1) .MinPoint.Modify xlConditionValueNumber, 0 .MaxPoint.Modify newtype:=xlConditionValueNumber, newvalue:= _ Range(FirstColumn & RowCounter).Offset(0, 2 * i + 1).Value .BarFillType = xlDataBarFillSolid End With ' Cell is NOTHING 'Case Is = vbNullString 'Range(FirstColumn & RowCounter).Offset(0, 2 * i).Interior.Color = 6750054 End Select Next i End If Next RowCounter 'Hide Total Columns For i = 0 To Categories - 1 Range(FirstColumn & "1").Offset(0, 2 * i + 1).EntireColumn.Hidden = True Next i End Sub 

Answer 1

我已经想出了这个（和其他一些！）问题的答案。

答案是，格式化过程正在将约5000个单独的条件格式化规则应用于单元格。 应用格式本身发生得非常快。

但是，任何后续的单元删除操作都需要很长的时间（相对），因为它必须通过刷新大约5,000个条件格式化规则。