Run Time Error 91 during Find using Array - excel

Question

Not had idea what the root cause for the error it only occur when the program try to find the value in array at the third value.
Public Sub GetBGA()
Dim PMIC() As String
Dim PartNumber1 As Long
Dim Counter As Long
Worksheets("Test1").Select
PartNumber1 = Range("A1", Range("A1").End(xlDown)).Cells.Count
ReDim PMIC(1 To PartNumber1)
For Counter = 1 To PartNumber1
PMIC(Counter) = Range("A1").Offset(Counter - 1, 0).Value
Next Counter
For Counter = 1 To PartNumber1
Worksheets("Test2").Select
Cell.Find(What:=PMIC(Counter), After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
ActiveCell.EntireRow.Copy
Worksheets("Test3").Select
Rows(1).Insert
Next Counter
End Sub

Answer 1

Copy Matching Rows
Option Explicit
Sub GetBGA()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Lookup
Dim lws As Worksheet: Set lws = wb.Worksheets("Test1")
Dim lfCell As Range: Set lfCell = lws.Range("A1")
Dim llCell As Range: Set llCell = lws.Cells(lws.Rows.Count, "A").End(xlUp)
Dim lrg As Range: Set lrg = lws.Range(lfCell, llCell)
Dim lrCount As Long: lrCount = lrg.Rows.Count
Dim lData() As Variant
If lrCount = 1 Then
ReDim lData(1 To 1, 1 To 1): lData(1, 1) = lrg.Value
Else
lData = lrg.Value
End If
' Source (don't you know the column?)
Dim sws As Worksheet: Set sws = wb.Worksheets("Test2")
Dim srg As Range
Dim slCell As Range
With sws.UsedRange
Set slCell = .Cells(.Rows.Count, .Columns.Count)
Set srg = sws.Range("A1", slCell)
End With
' Destination
Dim dws As Worksheet: Set dws = wb.Worksheets("Test3")
Dim drrg As Range: Set drrg = dws.Range("A1").Resize(, srg.Columns.Count)
' Loop (are you sure about 'xlPart' and '.Insert'?).
Application.ScreenUpdating = False
Dim lr As Long
Dim srrg As Range
Dim sCell As Range
For lr = lrCount To 1 Step -1 ' switch order with 'For lr = 1 To lrCount'
Set sCell = srg.Find(lData(lr, 1), slCell, xlFormulas, xlPart, xlByRows)
If Not sCell Is Nothing Then
Set srrg = srg.Rows(sCell.Row)
srrg.Copy
drrg.Insert
End If
Next lr
Application.ScreenUpdating = True
' Inform.
MsgBox "Data copied.", vbInformation
End Sub