Improve Speed of VBA Cells.Find Loop - performance

Question

I'm new to writing Macros and would love some help improving the speed on this one.
I have a sheet with 35,000+ rows, and I'm looping through it to find each instance of a value (OldSKU), grabbing the SKUSubset data associated with it (which has a variable number of rows), and pasting it into a new sheet (SubsetImporter) at the first empty row.
Right now, it can take 5 minutes to loop through and find all the instances of a SKU that shows up multiple times.
OldSKU will only ever show up in Column B. Is there a way to improve the speed of this loop? Possibly defining the range that it should search through?
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

Lightly-tested:
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