提高VBA Cells.Find Loop的速度

Question

我刚开始编写宏，并希望能帮助提高速度。

我有一张包含35,000多行的工作表，我正在遍历它以查找值的每个实例（OldSKU），抓取与其关联的SKUSubset数据（其中包含一个变量）行数），并将其粘贴到第一个空行的新工作表（SubsetImporter）中。

现在，循环可能需要5分钟，找到多次出现的SKU的所有实例。

OldSKU只会出现在B列中。有没有办法提高这个循环的速度？可能定义它应该搜索的范围？

Sub UpdateSKU()

Dim OldSKU As Long
Dim NewSKU As Long
Dim SKUSubset As String
Dim SubsetRange As Range
Dim aPlace As Range
Dim bPlace As Range
Dim SubsetPastePlace As Long

OldSKU = Sheets("Rollover Request").Range("A2")
NewSKU = Sheets("Rollover Request").Range("B2")

'UPDATE SUBSET IMPORTER
Sheets("Subset Exporter").Activate

Set aPlace = Cells.Find(What:=OldSKU, After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)

SKUSubset = Cells.Find(What:=OldSKU, After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Offset(0, -1).Value

Set bPlace = aPlace

Set aPlace = Cells.Find(What:=OldSKU, After:=aPlace, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)

Range("A1", Cells(1, 1).SpecialCells(xlLastCell)).AutoFilter Field:=1, Criteria1:=SKUSubset
Range(ActiveSheet.UsedRange.SpecialCells(xlLastCell), Cells(2, 1)).Copy

SubsetPastePlace = Sheets("Subset Importer").Cells(Rows.Count, 1).End(xlUp).Offset(1).Row

Sheets("Subset Importer").Range("A" & SubsetPastePlace).PasteSpecial Paste:=xlPasteValues,     Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

Application.CutCopyMode = False

Sheets("Subset Exporter").Activate
Sheets("Subset Exporter").Range("A2").Select
Sheets("Subset Exporter").ShowAllData

If bPlace.Row < aPlace.Row Then
    Do
        SKUSubset = aPlace.Offset(0, -1).Value

        Range("A1", Cells(1, 1).SpecialCells(xlLastCell)).AutoFilter Field:=1, Criteria1:=SKUSubset
        Range(ActiveSheet.UsedRange.SpecialCells(xlLastCell), Cells(2, 1)).Copy

        SubsetPastePlace = Sheets("Subset Importer").Cells(Rows.Count, 1).End(xlUp).Offset(1).Row

        Sheets("Subset Importer").Range("A" & SubsetPastePlace).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False

        Application.CutCopyMode = False

        Sheets("Subset Exporter").Activate
        Worksheets("Subset Exporter").ShowAllData

        Set bPlace = aPlace
        Set aPlace = Cells.Find(OldSKU, After:=aPlace, LookIn:=xlValues, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)

    Loop Until aPlace.Row < bPlace.Row
End If

End Sub

Answer 1

轻轻测试：

Sub UpdateSKU()

    Dim OldSKU As Long
    Dim NewSKU As Long
    Dim SKUSubset As String
    Dim SubsetRange As Range
    Dim skuCells As Collection, shtExp As Worksheet, shtImp As Worksheet
    Dim skuCell

    Set shtExp = Sheets("Subset Exporter")
    Set shtImp = Sheets("Subset Importer")

    OldSKU = Sheets("Rollover Request").Range("A2")
    NewSKU = Sheets("Rollover Request").Range("B2")

    Set skuCells = FindAll(shtExp.Columns(2), OldSKU) 'get all instances of SKU

    shtExp.Activate
    For Each skuCell In skuCells

        SKUSubset = skuCell.Offset(0, -1).Value

        shtExp.Range("A1", Cells(1, 1).SpecialCells(xlLastCell)).AutoFilter _
                                   Field:=1, Criteria1:=SKUSubset

        shtExp.Range(shtExp.Cells(2, 1), shtExp.UsedRange. _
                       SpecialCells(xlLastCell)).Copy

        shtImp.Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial _
           Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False

        shtExp.ShowAllData

    Next skuCell

End Sub

'return a Collection containing all cells with value [findWhat]
Function FindAll(rngToSearch As Range, findWhat As Long) As Collection
Dim rv As New Collection, f As Range, add1 As String
    Set f = rngToSearch.Find(what:=findWhat, LookIn:=xlValues, Lookat:=xlWhole)
    If Not f Is Nothing Then
        add1 = f.Address()
        Do While Not f Is Nothing
            rv.Add f
            Set f = rngToSearch.FindNext(after:=f)
            If f.Address = add1 Then Exit Do
        Loop
    End If
    Set FindAll = rv
End Function