Repeat Search Function

[Sarfaraz]

Hi,
I have a long list of incomplete names in "sheet2" which i need to search in "sheet1" which have complete information and paste it into "sheet2". If search doesn't find suitable pair go back to "sheet2" and picks the next value. Repeat this till it finds a blank cell. I have recorded the macro. Can somebody help me in making this code in such a way that it repeats itself until the list is complete.

Selection.Copy
    Sheets("Sheet1").Select
    Range("A1").Select
    Cells.Find(What:="abc", After:=ActiveCell, LookIn:=xlFormulas2, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
    Range("A2:C2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet2").Select
    Range("A1").Select
    Cells.FindNext(After:=ActiveCell).Activate
    Range("B2").Select
    ActiveSheet.Paste
    Range("A3").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet1").Select
    Range("A1").Select
    Cells.Find(What:="ijk", After:=ActiveCell, LookIn:=xlFormulas2, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, SearchFormat:=False).Activate
    Sheets("Sheet2").Select
    Range("A4").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet1").Select
    Range("A1").Select
    Cells.Find(What:="xyz hol", After:=ActiveCell, LookIn:=xlFormulas2, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    Range("A3:C3").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet2").Select
    Range("A1").Select
    Cells.FindNext(After:=ActiveCell).Activate
    Range("B4").Select
    ActiveSheet.Paste
Range("A4").Select
    Application.CutCopyMode = False
End Sub

Thanks

[Dave]

Hi Sarfaraz. You can trial this code. Please keep a copy of your wb before testing. HTH. Dave

Sub test()
Dim Cnt As Long, Cnt2 As Long, DLen As Integer
Dim TStr As String, Flag As Boolean, TempStr As String
'search partial words
For Cnt2 = 2 To Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
Flag = False
TStr = CStr(Sheets("sheet2").Range("A" & Cnt2).Value)
'loop letters of partial word
For DLen = 1 To Len(TStr)
'loop whole words
TempStr = vbNullString
For Cnt = 2 To Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
'compare partial words to whole word
If LCase(Mid(Sheets("Sheet1").Cells(Cnt, 2), DLen, Len(TStr))) = LCase(TStr) Then
TempStr = TempStr & LCase(Mid(Sheets("Sheet1").Cells(Cnt, 2), DLen, Len(TStr)))
'ensure match includes all letters of partial word
If Left(Sheets("sheet1").Cells(Cnt, 2), Len(TempStr)) = TStr Then
Sheets("sheet2").Cells(Cnt2, 3) = Sheets("sheet1").Cells(Cnt, 2) 'name
Sheets("sheet2").Cells(Cnt2, 4) = Sheets("sheet1").Cells(Cnt, 3) 'cust no
Sheets("sheet2").Cells(Cnt2, 2) = Sheets("sheet1").Cells(Cnt, 1) 'plant no
Flag = True
End If
End If
Next Cnt
'if match found move to next partial word
If Flag Then
Exit For
End If
Next DLen
Next Cnt2
End Sub

[Sarfaraz]

Great, thanks a lot, it worked perfectly fine.

[Dave]

You are welcome. Thanks for posting your outcome. Dave