我正在处理一个相当大的工作簿（50MB），我正在尝试运行一个迭代表中所有单元格的程序（是的，我知道这很慢，但是它＆＃39;不可避免的）并删除一些并格式化其他人。
事实证明，无论出于何种原因，将数据复制到新工作簿并运行程序要快得多。
但是，我尝试用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
答案 0 :(得分：2)
我已经找到了答案（以及其他一些！）的问题。
答案是格式化过程将〜5000个单独的条件格式规则应用于单元格。应用格式化本身很快就会发生。
但是，任何后续的单元格删除都需要花费很长时间（相对），因为它必须通过刷新大约5,000条条件格式规则。