Excel 2010 VBA – 如何优化此代码，使其不会滞后？
我是VBA的新手，最近我创build了一些macros。 我目前有一个工作，但有时不是很合作。 我已经做了一些关于如何优化VBA代码的阅读，但是我还没有走得太远。 我明白使用Select是不好的，我已经删除了尽可能多的Select线我自己。 我也读过很多， if statements和loops结合起来也很难运行（当然我也有两个loops倍数）。
所以我知道为什么我的代码不好，但我真的不知道如何解决它的一些原因。 我补充说
Application.ScreenUpdating = False Application.ScreenUpdating = True
我的macros也是如此。 这有帮助，但不是很多。 我有其他的macros可以运行很长时间，永远不会冻结。 如果该macros在10-15秒内未完成，则此macros会冻结。 如果我只有几百行数据，它没有问题。 如果我有几行1000行的数据，它会在冻结之前没有完成。
Option Explicit Sub FillGainerPrices() Application.ScreenUpdating = False 'Search each name on "Gainer Prices" and if the same name is on "Gainers", but not on Gainer Prices _ move it over to Gainer Prices tab. Then call Historical Query and Fill Names Dim LastRow1 As Long LastRow1 = Sheets("Gainers").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Dim LastRow2 As Long LastRow2 = Sheets("Gainer Prices").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Dim Name1 As Range Dim Name2 As Range For Each Name1 In Sheets("Gainers").Range("B2:B" & LastRow1) Set Name2 = Sheets("Gainer Prices").Range("A2:A" & LastRow2).Find(Name1, LookIn:=xlValues, LookAt:=xlWhole) If Name2 Is Nothing Then If Name1.Offset(0, -1) < Date - 15 Then Name1.Copy Sheets("Gainer Prices").Select Range("C" & Cells.Rows.Count).End(xlUp).Offset(1, -2).Select ActiveSheet.Paste Call HistoricalQuery End If End If Next Name1 Application.ScreenUpdating = True 'Fill in Names and remaining symbols here Call FillNamesAndSymbols End Sub
Call HistoricalQuery并Call FillNamesAndSybmols非常快，当我自己运行它们时似乎没有任何问题，所以我不认为它们引起了问题。 我猜这个问题是search一个名称1000年的时代，然后复制和粘贴一遍又一遍，但我不知道如何摆脱复制和粘贴部分没有macros给我错误的结果。
macros的最终目标是去第二张纸，看看这些名字是否在第一张纸上。 如果没有，则将名称移动过来，然后对其移动的每个名称调用另一个macros来提取该名称的历史数据。 最后，它只是做一些格式化，填充或删除空白单元格。 如果有人能指导我正确的方向，我将不胜感激。 谢谢！
试试这个代码。
改进措施：
- 时间：我的代码：
0.8828125秒，你的代码：10.003秒。 （在两张纸上testing1000行） - 我使用数组来存储第二个表的值：
arr = Sheets("Gainer Prices").Range("A2:A" & LastRow2).Value– 对于大数据要快得多 - 我正在使用
Application.Match而不是Range.Find– 它也更快。 - 我正在使用
Range(..).Value = Range(..).Value而不是copy/paste - 避免使用select / active语句
Sub FillGainerPrices() Dim LastRow1 As Long Dim LastRow2 As Long Dim Lastrow3 As Long Dim Name1 As Range Dim sh1 As Worksheet Dim sh2 As Worksheet Dim arr As Variant 'remember start time Dim start as Long start = Timer Application.ScreenUpdating = False Set sh1 = ThisWorkbook.Sheets("Gainers") Set sh2 = ThisWorkbook.Sheets("Gainer Prices") With sh1 LastRow1 = .Cells(.Rows.Count, "B").End(xlUp).Row End With With sh2 LastRow2 = .Cells(.Rows.Count, "A").End(xlUp).Row arr = .Range("A2:A" & LastRow2).Value End With For Each Name1 In sh1.Range("B2:B" & LastRow1) If IsError(Application.Match(Name1.Value, arr, 0)) Then If Name1.Offset(0, -1) < Date - 15 Then With sh2 Lastrow3 = .Cells(.Rows.Count, "C").End(xlUp).Row .Range("A" & Lastrow3 + 1).Value = Name1.Value End With Call HistoricalQuery End If End If Next Name1 'Fill in Names and remaining symbols here Call FillNamesAndSymbols Application.ScreenUpdating = True 'To see timing result press CTRL+G in the VBE window, or change Debug.Print to MsgBox Debug.Print "Code evaluates for: " & Timer - start End Sub
代替
Name1.Copy Sheets("Gainer Prices").Select Range("C" & Cells.Rows.Count).End(xlUp).Offset(1, -2).Select ActiveSheet.Paste
你可以尝试这样的事情：
Name1.copy destination:=Sheets("Gainer Prices").Range("C" & Cells.Rows.Count).End(xlUp).Offset(1, -2)
也许
Sheets("Gainer Prices").Range("C" & Cells.Rows.Count).End(xlUp).Offset(1, -2).value=Name1.value