查找和查找下一个以复制与所有匹配项相对应的数据 [英] Find and FindNext to copy data corresponding to all matches

问题描述

我要搜索第BD页的第5列对于与称为"alocacao"的值匹配的所有条目，对于在我的工作表"Plan1"上.然后将列2上的值复制到名为"tecnico1"的单元格中.(其他单元称为"tecnico2，tecnico3和tecnico4").

I want to search Column 5 on sheet "BD" for all the entries that match a value called "alocacao" on my sheet "Plan1". Then copy the value on Column 2 to the cell called "tecnico1" (the other cells are called "tecnico2, tecnico3 and tecnico4").

值为TESTE 2的单元格为"alocacao".

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

我尝试了Find和FindNext:

I tried Find and FindNext:

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

我知道

运行时错误1004

Run-time error 1004

但代码未突出显示.

编辑

我更改了一部分以测试是否会将值粘贴到单元格B26上.

I changed a part of it to test if it will paste the value on cell B26.

现在我得到

运行时错误438

Run-time error 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

推荐答案

好吧，假设您在工作表"Plan1" 中有4个命名单元，名称分别为 tecnico1，tecnico2，tecnico3和tecnico4 ，我建议进行以下修改，请记住，我们应在 4 匹配的名称范围为 tecnico 的处停止匹配:

Ok supposing you have 4 named cells in sheet "Plan1" with names tecnico1, tecnico2, tecnico3 and tecnico4, I suggest the following modification, having in mind that we should stop at 4 matches which the number of named ranges 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

这篇关于查找和查找下一个以复制与所有匹配项相对应的数据的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！