使用Array查找时运行时错误91

Question

不知道错误的根本原因是什么，只有当程序试图在数组中找到第三个值时才会发生。

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

复制匹配行

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