Question

我是VBA的新手，我最近创建了一些宏。我目前有一个有效，但有时并不合作。我已经完成了关于如何优化VBA代码的一堆阅读，但我还没有走得太远。我知道使用Select是不好的，而且我已经尽可能多地删除了Select行。我还读到许多if statements与loops结合起来也很难（当然我有两倍的倍数）。

所以我知道我的代码很糟糕的一些原因，但我真的不知道如何修复它。我添加了

    Application.ScreenUpdating = False
    Application.ScreenUpdating = True

也是我的宏。这有所帮助，但并不多。我有其他宏可以运行很长时间，永远不会冻结。如果它在10-15秒内没有完成，该宏会冻结。如果我只有几行100行数据就没问题。如果我有几千行数据，它在冻结之前就不会完成。

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非常快，当我自己运行时似乎没有任何问题，所以我不认为它们会导致问题。我猜这个问题是搜索一个名称1000次，然后一遍又一遍地复制和粘贴，但我无法弄清楚如何摆脱复制和粘贴部分而不是宏给我错误的结果。

宏的最终目标是转到第二张，看看这些名字是否在第一张纸上。如果没有，它会移动名称，然后为它移动的每个名称调用另一个宏来提取该名称的历史数据。最后，它只是进行一些格式化，填写或删除空白单元格。如果有人能指引我正确的方向，我会很感激。谢谢！

Answer 1

试试这段代码。

<强>改进措施：

时间安排：我的代码：0.8828125秒，您的代码：10.003秒。（在两张纸上测试1000行）
我正在使用数组来存储第二张表中的值：arr = Sheets("Gainer Prices").Range("A2:A" & LastRow2).Value - 对于大量数据来说要快得多
我正在使用Application.Match代替Range.Find - 它也更快。
我正在使用Range(..).Value = Range(..).Value代替copy/paste
avoid using select/active statement

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

Answer 2

而不是

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

Excel 2010 VBA - 如何优化此代码以使其不会滞后？

2 个答案: