Find和FindNext复制所有匹配对应的数据

我想在工作表“BD”的第 5 列中搜索与工作表“Plan1”上名为“alocacao”的值匹配的所有条目。 然后将第 2 列上的值复制到名为“tecnico1”的单元格（其他单元格称为“tecnico2、tecnico3 和 tecnico4”）。

The cell with the value TESTE 2 is the "alocacao".

我尝试了查找和查找下一个：

Sub VerifProd_Click()
    
    Dim FoundCell As Range
    Dim LastCell As Range
    Dim FirstAddr As String
    Dim fnd As String
    Dim i As Long
    
    i = 2
    fnd = Sheets(1).Range("alocacao").Value
    
    With Sheets("BD").Columns(5)
        Set LastCell = .Cells(.Cells.Count)
    End With
    
    Set FoundCell = Sheets("BD").Columns(5).Find(what:=fnd, after:=LastCell)
    
    If Not FoundCell Is Nothing Then
        FirstAddr = FoundCell.Address
    End If
    
    Do Until FoundCell Is Nothing
        Sheets("BD").Cells(i,2).Copy Sheets("Plan1").Range("tecnico" & i).Value
        i = i + 1
        Set FoundCell = Sheets("BD").Columns(5).FindNext(after:=FoundCell)
        If FoundCell.Address = FirstAddr Then
            Exit Do
        End If
    Loop
    
End Sub

I get

运行时错误1004

但代码没有突出显示。

EDIT

我更改了其中的一部分以测试它是否会将值粘贴到单元格 B26 上。

现在我明白了

运行时错误438

With Sheets("BD").Columns(5)
    Set LastCell = .Cells(.Cells.Count)
End With
    
Set FoundCell = Sheets("BD").Columns(5).Find(what:=fnd, after:=LastCell)
    
If Not FoundCell Is Nothing Then
    FirstAddr = FoundCell.Address
End If
    
Do Until FoundCell Is Nothing
    Sheets("Plan1").Range("B26") = FoundCell.Adress.Offset(0, -3).Value
        
    Set FoundCell = Sheets("BD").Columns(5).FindNext(after:=FoundCell)
    If FoundCell.Address = FirstAddr Then
        Exit Do
    End If
Loop

好的，假设工作表中有 4 个命名单元格"Plan1"有名字tecnico1, tecnico2, tecnico3 and tecnico4，我建议进行以下修改，记住我们应该停在4与命名范围的数量相匹配tecnico:

Sub VerifProd_Click()
    Dim FoundCell As Range, FirstAddr As String, fnd As String, i As Long

    fnd = Sheets(1).Range("alocacao").value
    Set FoundCell = Sheets("BD").Columns(5).Find(what:=fnd, _
        After:=Sheets("BD").Cells(Rows.count, 5), Lookat:=xlPart, _
        LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlNext)
 
    If FoundCell Is Nothing Then Exit Sub
    FirstAddr = FoundCell.Adress
    Do
        i = i + 1
        Sheets("Plan1").Range("tecnico" & i).value = FoundCell.Offset(,-3).Value2
        Set FoundCell = Sheets("BD").Columns(5).FindNext(After:=FoundCell)
    Loop Until FoundCell.Address = FirstAddr Or i >= 4
End Sub