Range.Find 多个条件，然后将结果复制/粘贴到不同的工作表

Question

I'm trying to use Range.Find to search in the "Database" sheet to match all the criteria in the "Search" sheet. If all the criteria are met, then it copies the entire row (from "Database") and pastes it into the "Results" sheet. It keeps looping until all the results that match are found, and copies/pastes the results as a new row for each match.

For example, this is what "Search" might looks like , where it'd take the criteria from Column I and find all results in "Database" (in no particular order) by comparing it to the construction code (Column D). In this case, the 2nd and 3rd row matches all the criteria from "Search", so it'd be copied and pasted to "Results"

I'm new to VBA and have looked through many posts to try and put it all together. Right now my issue is nothing is showing up in "Results" (I'm guessing I haven't written it to search it properly). Any help would be appreciated, thanks.

Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim lastRow As Long, j As Long

Set ws1 = Sheets("Database")
Set ws2 = Sheets("Results")
Set ws3 = Sheets("Search")
lastRow = Cells(Rows.Count, "A").End(xlUp).Row

Dim Criteria As Variant
Criteria = ws3.Range("I4:I7").Value

Set searchRng = ws1.Range("D7:D98")
Set rngfindvalue = searchRng.Find(what:=Range("I4"), Lookat:=xlPart)

If Not rngfindvalue Is Nothing Then

    rngFirstAddress = rngfindvalue.Row
    Do
        If rngfindvalue.Value = Criteria(2, 1) And _
           rngfindvalue.Value = Criteria(3, 1) And _
           rngfindvalue.Value = Criteria(4, 1) Then

            lastRow = lastRow + 1
            j = rngfindvalue.Row
            ws1.Rows(j).EntireRow.Copy ws2.Range("A" & lastRow)

        Set rngfindvalue = searchRng.FindNext(rngfindvalue)
        End If
    Loop Until rngfindvalue Is Nothing Or rngfindvalue.Row = rngFirstAddress
End If

If Not rngfindvalue Is Nothing Then
    Application.Goto Reference:=Worksheets("Results").Range("A1")
Else
    MsgBox "No results matched your search criteria."
End If

Answer 1

Try the next code, please. It should be very fast. It uses arrays and works only in memory. The criteria evaluation result is loaded in an array and dropped in the "Results" worksheet at once. The code assumes that the columns header of the "Database" worksheet is on the 6th row:

Sub CopyRowsByCriteria()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim lastRow As Long, i As Long, j As Long, k As Long, El As Variant
Dim arrCrit As Variant, arrDB As Variant, arrFin As Variant, boolExclude As Boolean

Set ws1 = Sheets("Database")
Set ws2 = Sheets("Results")
Set ws3 = Sheets("Search")
lastRow = ws1.Cells(Rows.Count, "A").End(xlUp).row

arrCrit = ws3.Range("I4:I7").Value
arrDB = ws1.Range("A6:D" & lastRow).Value 'including head of the table

ReDim arrFin(1 To 4, 1 To UBound(arrDB, 1))
k = k + 1
For i = 1 To 4
    arrFin(i, k) = arrDB(1, i) 'fill head of the table
Next i

For i = 2 To UBound(arrDB, 1)
    For Each El In arrCrit
        If InStr(arrDB(i, 4), El) = 0 Then boolExclude = True: Exit For
    Next
    If Not boolExclude Then
        k = k + 1
        For j = 1 To 4
            arrFin(j, k) = arrDB(i, j)
        Next j
    End If
    boolExclude = False
Next i
ReDim Preserve arrFin(1 To 4, 1 To k)
'Drop the arrFin data in the Results sheet
ws2.Range("A1").Resize(UBound(arrFin, 2), 4).Value = WorksheetFunction.Transpose(arrFin)
End Sub