这个宏有效，但是在任何地方我都可以加速宏吗？由于数据量的增加，我需要它至少搜索1000行。每次都不会有1,000行数据，但有时会。
`Sub Issues_Formatting2()
' Issues_Formatting Macro
'
Application.ScreenUpdating = False
ActiveSheet.Cells.UnMerge
ActiveSheet.Name = "Issues Report"
With Worksheets("Issues Report").Cells.Font
.Name = "Trebuchet MS"
.Size = 10
End With
Range("A1:A4").Select
Selection.ClearContents
Range("A1").Select
ActiveSheet.Pictures.Insert( _
"R:\Marketing\Logos\Wolters Kluwer Health\rgb-files\WKH-«_health-logo-185-rgb-.jpg" _
).Select
Selection.ShapeRange.ScaleWidth 0.5125, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 0.525, msoFalse, msoScaleFromTopLeft
Columns("A:A").Select
On Error GoTo Rows
Cells.Find(What:="Implementation Issue: Issue #", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
Range("A7:A" & ActiveCell.Row - 1).EntireRow.Delete
Rows:
Rows("7:7").RowHeight = 30.75
Range("A7:Q7").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 5296274
.TintAndShade = 0
.PatternTintAndShade = 0
End With
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
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A7").Select
ActiveCell.FormulaR1C1 = "Issue #"
Range("B7").Select
ActiveCell.FormulaR1C1 = "Title"
Range("E7").Select
ActiveCell.FormulaR1C1 = "Responsible Party"
Range("J7").Select
ActiveCell.FormulaR1C1 = "Comments"
Range("M7").Select
ActiveCell.FormulaR1C1 = "City"
Range("N7").Select
ActiveCell.FormulaR1C1 = "State"
Range("P7").Select
ActiveCell.FormulaR1C1 = "Owner Name"
Range("Q7").Select
Columns("Q:Q").ColumnWidth = 23.57
Range("J7").Select
Columns("A:A").ColumnWidth = 8.43
Columns("C:C").ColumnWidth = 8.86
Columns("C:C").ColumnWidth = 7.43
Columns("D:D").ColumnWidth = 7.43
Columns("E:E").ColumnWidth = 11.86
Columns("F:F").ColumnWidth = 11.57
Columns("G:G").ColumnWidth = 12
Columns("I:I").ColumnWidth = 8.6
Columns("L:L").ColumnWidth = 12.2
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 3
Columns("O:O").ColumnWidth = 20.43
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
Rows("7:7").RowHeight = 25.5
Selection.FormatConditions.Add Type:=xlTextString, String:= _
"Implementation Record Type", TextOperator:=xlContains
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 12611584
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Range("I17").Select
Range("A8:Q8").Select
ActiveWindow.FreezePanes = True
ActiveWindow.SmallScroll Down:=-9
Range("J8:J1000").Select
Selection.ClearContents
Dim g As Long
For g = 7 To 1000
Cells.Find(What:=":", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Resize(1, 17).Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Next
Dim p As Long
For p = 7 To 1000
Cells.Find(What:="Grand", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Resize(1, 17).Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
Next
Dim rng As Range
Set rng = ActiveSheet.Range("J7:J1000")
For Each Cell In rng
Cell.Formula = "=IFERROR(VLOOKUP(RC[-9], Sheet1!C[-9]:C, 10, FALSE), """")"
Next Cell
Dim i As Long
For i = 7 To 1000
Cells.Find(What:="Implementation Record Type:", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
ActiveCell.Offset(1, 0).Resize(1, 17).Interior.ColorIndex = 23
ActiveCell.Font.ColorIndex = 2
ActiveCell.Interior.ColorIndex = 23
Next
Columns("A:A").Select
On Error Resume Next
Cells.Find(What:="Grand Totals", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
ActiveCell.Offset(1, 0).Resize(1, 17).Interior.Color = 5296274
ActiveCell.Resize(1, 17).Interior.Color = 5296274
ActiveWindow.DisplayGridlines = True
For Each Cell In Range("I2:I1000")
If UCase(Cell.Value) Like "*HIGH*" Then
Cell.Font.Color = vbRed
Cell.Font.Bold = True
End If
If UCase(Cell.Value) Like "*MEDIUM*" Then Cell.Font.Bold = True
Next Cell
For Each Cell In Range("C2:C1000")
If UCase(Cell.Value) Like "*RISK*" Then
Cell.Font.Color = vbRed
Cell.Font.Bold = True
End If
Next Cell
[A7:A1000].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Cells.Select
Cells.EntireRow.AutoFit
Application.ScreenUpdating = True
End Sub
答案 0 :(得分：0)
您当前的代码强制Excel搜索工作表中的每个单元格，迫使Excel查看超过17,000,000,000个单元格的2007或更高版本。而不是Cells.Find，只在特定列中搜索短语“Implementation Issue：Issue＃”。例如，如果您要搜索的短语位于A列中，请使用类似
的内容Dim Rng As Range
Set Rng = Range(Cells(1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 1))
Rng.Find(What:="Implementation Issue: Issue #", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
您可能希望在删除行后重置Rng变量，以便Excel在每次迭代后查看更少的单元格。
另外，我总是将以下内容添加到我的子模块中（您已经有一个）。第一个阻止Excel推送任何屏幕更新，直到宏完成（这是执行期间最大的时间节省）。第二个关闭宏中的所有自动计算，如果你有任何VLOOKUPS或其他类似数组的公式，这将节省大量的时间。最后一个关闭简单显示，例如“您确定要保存此工作簿吗？”这可能会导致长时间运行的宏出现问题，您可能会离开计算机。
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
然后在最后将它们恢复正常（很可能是大多数人想要自动计算，如果他们知道手动计算，那么他们应该知道如何将它们设置回手册）。
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
最后一条建议是用下面的内容替换你的GoTo功能。 GoTo消息很难调试，打破了代码流，并且通常是在可以避免的情况下使用的不良做法（这里可以避免）。
On Error Resume Next
Err.Number = 0
'*****DO YOUR CODE WHICH MIGHT RETURN AN ERROR*****
Rng.Find(blah_blah_blah).Activate
If Err.Number = 0 Then
'No Error Occurred
Else
Debug.Print "An error occurred: " & Err.Number
End
修正了第一个正确编译的代码片段。
答案 1 :(得分：0)
在编写Excel VBA宏时，您应该尝试避免 选择 。
选择适用于人类用户：使用鼠标或键盘选择内容，然后对选择执行某些操作。
VBA代码通常应直接在 范围 上运行，而无需选择或激活它们。代码将更容易阅读，速度更快。尝试重写代码而不使用关键字Select，Selection，Activate，ActiveCell。
看起来你的循环运行了1000次，即使在Cells.Find停止找到任何东西后也是如此。请改用While（或Until）循环。你也应该使用.FindNext而不是每次都做一个新鲜的。
在此代码中：
For Each Cell In Range("I2:I1000")
If UCase(Cell.Value) Like "*HIGH*" Then
您实际上可以使用Find而不是Like "*HIGH*"，因为Find会默认搜索子字符串，默认情况下不区分大小写。
您的代码分几个阶段运行。尝试在每个阶段进行计时，以了解您需要优化的位置。自由使用Debug.Print，并定位窗口，以便在宏执行时调试窗口仍然可见。
重写时，你的宏应该在5秒内运行！