Performance 提高VBA单元格的速度。查找循环

我对编写宏还不熟悉，希望能得到一些帮助来提高这个宏的速度

我有一个35000多行的工作表，我在其中循环查找一个值OldSKU的每个实例，获取与之关联的SKUSET数据，该数据具有可变的行数，并将其粘贴到第一个空行的新工作表substimporter中

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

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

轻度测试：

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

---

如果你只想搜索colB，那么就不要搜索Cells.Find，你可以使用Columns2.Find。。。很难理解你在这里做的事情，所以如果你能发布一个可能有用的部分源数据的屏幕截图。首先对你的数据应用一个过滤器，然后循环其余的记录，不是更容易吗？嗨@TimWilliams，我附上了源数据的格式。基本上，我在B列中查找SKU，然后在A列中过滤组ID。那么，在找到SKU后，如何确定要复制哪些行？上面没有SKU的所有行？找到SKU后，向左偏移以获取组ID，然后将其定义为SKU子集。然后，我们对SKU子集进行筛选，以获得要复制的行。