Ended up with this Code that checks whether any of three input boxes contain data, then finds and copies across all the records on the Database that completely or partially match whichever cell was filled in.
Posting it here as it may help someone else.
Option Explicit
Dim e As Long, f As Long
Dim fnd As String, FirstFound As String, strSearch As String
Dim FoundCell As Range, MyRange As Range, rng As Range
Sub MULTITEST()
'Find last row in SHeet 3
With Sheet3
f = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
e = 4
If IsEmpty(Sheet2.Range("D4").Value) = False Then
Set MyRange = Sheet3.Range("A2:A" & f)
strSearch = Sheet2.Range("D4")
Sheet3.Select
Range("A2").Select
Set FoundCell = MyRange.Find(What:=strSearch, after:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not FoundCell Is Nothing Then
FirstFound = FoundCell.Address
'Loop until cycled through all unique finds
Do Until FoundCell Is Nothing
Sheet2.Range("L" & e) = FoundCell.Offset(0, 49)
Sheet2.Range("M" & e) = FoundCell
Sheet2.Range("N" & e) = FoundCell.Offset(0, 1)
Sheet2.Range("O" & e) = FoundCell.Offset(0, 2)
e = e + 1
Set rng = FoundCell
'Find next cell with fnd value
Set FoundCell = MyRange.FindNext(after:=FoundCell)
'Test to see if cycled through to first found cell
If FoundCell.Address = FirstFound Then Exit Do
Loop
End If
'Then used same approach to find the matches if the Family Name was the only criteria
ElseIf IsEmpty(Sheet2.Range("D6").Value) = False Then. . .
'And if the Project Name was the only criteria
ElseIf IsEmpty(Sheet2.Range("D9").Value) = False Then. . .
'And if all three criteria are blank
ELSE EXIT SUB
May also lead someone to post a more elegant solution that does the job?
Ochimus
Bookmarks