Macro for Partial String in Text

[kclong]

I want to write an macro where it searches for text in a column, but the text may be a partial string. The text is in column B, with account numbers in column A, like this:

Column A Column B
1100 Jay
1101 Jack
1102 Jackson
1103 Jacksony
1104 Jefferson

For example, I want to search on Jack in column B. In the above example, I want it to find accounts 1101, 1102, and 1103, and to copy that information to another spreadsheet, say, sheet2. If possible, I'd like it to copy the first account number and name, 1101 Jack, and if that's not what the user wants, they click next and they see 102 Jackson and so forth. Any help you can give me is greatly apprecited.

 

[VoG]

Try

Sub fnd()
Dim rfirst As Range, r As Range, X As String, LR As Long, response As VbMsgBoxResult
X = InputBox("Name to find?")
Set rfirst = Columns(2).Find(What:=X, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If rfirst Is Nothing Then
    MsgBox ("Not found")
    Exit Sub
End If
response = MsgBox("Copy " & rfirst.Offset(0, -1).Value & vbTab & rfirst.Value & " ?", vbYesNo + vbQuestion)
If response = vbYes Then
    With Sheets("Sheet2")
        LR = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A" & LR + 1).Value = rfirst.Offset(0, -1).Value
        .Range("B" & LR + 1).Value = rfirst.Value
    End With
End If
Set r = Columns(2).FindNext(After:=rfirst)
While (Not rfirst.Address = r.Address)
    response = MsgBox("Copy " & r.Offset(0, -1).Value & vbTab & r.Value & " ?", vbYesNo + vbQuestion)
    If response = vbYes Then
        With Sheets("Sheet2")
            LR = .Range("A" & Rows.Count).End(xlUp).Row
            .Range("A" & LR + 1).Value = r.Offset(0, -1).Value
            .Range("B" & LR + 1).Value = r.Value
        End With
    End If
    Set r = Columns(2).FindNext(After:=r)
Wend
End Sub

 

[kclong]

Thank you very much. One more follow up question if I may. The macro finds a possible match and then asks you if you want to copy that information. If I say No, it moves to the next possible match, which is perfect. If I say Yes, it copies the information and then finds the next possible match. How do I tell the macro to end if I answer Yes to that question?

 

[VoG]

Try

Sub fnd()
Dim rfirst As Range, r As Range, X As String, LR As Long, response As VbMsgBoxResult
X = InputBox("Name to find?")
Set rfirst = Columns(2).Find(What:=X, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If rfirst Is Nothing Then
    MsgBox ("Not found")
    Exit Sub
End If
response = MsgBox("Copy " & rfirst.Offset(0, -1).Value & vbTab & rfirst.Value & " ?", vbYesNo + vbQuestion)
If response = vbYes Then
    With Sheets("Sheet2")
        LR = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A" & LR + 1).Value = rfirst.Offset(0, -1).Value
        .Range("B" & LR + 1).Value = rfirst.Value
    End With
    Exit Sub
End If
Set r = Columns(2).FindNext(After:=rfirst)
While (Not rfirst.Address = r.Address)
    response = MsgBox("Copy " & r.Offset(0, -1).Value & vbTab & r.Value & " ?", vbYesNo + vbQuestion)
    If response = vbYes Then
        With Sheets("Sheet2")
            LR = .Range("A" & Rows.Count).End(xlUp).Row
            .Range("A" & LR + 1).Value = r.Offset(0, -1).Value
            .Range("B" & LR + 1).Value = r.Value
        End With
        Exit Sub
    End If
    Set r = Columns(2).FindNext(After:=r)
Wend
End Sub

 

[kclong]

I'm sorry, but one last question. What if I only want it to copy to a specific cell in Sheet 2 - say, cell A1. How do I change the macro? Again, thank you very much. This will be a big help.

 

[VoG]

Try

Sub fnd()
Dim rfirst As Range, r As Range, X As String, response As VbMsgBoxResult
X = InputBox("Name to find?")
Set rfirst = Columns(2).Find(What:=X, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If rfirst Is Nothing Then
    MsgBox ("Not found")
    Exit Sub
End If
response = MsgBox("Copy " & rfirst.Offset(0, -1).Value & vbTab & rfirst.Value & " ?", vbYesNo + vbQuestion)
If response = vbYes Then
    With Sheets("Sheet2")
        .Range("A1").Value = rfirst.Offset(0, -1).Value
        .Range("B1").Value = rfirst.Value
    End With
    Exit Sub
End If
Set r = Columns(2).FindNext(After:=rfirst)
While (Not rfirst.Address = r.Address)
    response = MsgBox("Copy " & r.Offset(0, -1).Value & vbTab & r.Value & " ?", vbYesNo + vbQuestion)
    If response = vbYes Then
        With Sheets("Sheet2")
            .Range("A1").Value = r.Offset(0, -1).Value
            .Range("B1").Value = r.Value
        End With
        Exit Sub
    End If
    Set r = Columns(2).FindNext(After:=r)
Wend
End Sub

 

[kclong]

I know I said last question, but this is it . I'd like to be on Sheet2 while the macro is searching on Sheet1 and bringing the data back to Sheet2. Is that possible? Again, thank you.

 

[VoG]

This should do that:

Sub fnd()
Dim rfirst As Range, r As Range, X As String, response As VbMsgBoxResult
X = InputBox("Name to find?")
Set rfirst = Sheets("Sheet1").Columns(2).Find(What:=X, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If rfirst Is Nothing Then
    MsgBox ("Not found")
    Exit Sub
End If
response = MsgBox("Copy " & rfirst.Offset(0, -1).Value & vbTab & rfirst.Value & " ?", vbYesNo + vbQuestion)
If response = vbYes Then
    With Sheets("Sheet2")
        .Range("A1").Value = rfirst.Offset(0, -1).Value
        .Range("B1").Value = rfirst.Value
    End With
    Exit Sub
End If
Set r = Sheets("Sheet1").Columns(2).FindNext(After:=rfirst)
While (Not rfirst.Address = r.Address)
    response = MsgBox("Copy " & r.Offset(0, -1).Value & vbTab & r.Value & " ?", vbYesNo + vbQuestion)
    If response = vbYes Then
        With Sheets("Sheet2")
            .Range("A1").Value = r.Offset(0, -1).Value
            .Range("B1").Value = r.Value
        End With
        Exit Sub
    End If
    Set r = Sheets("Sheet1").Columns(2).FindNext(After:=r)
Wend
End Sub

 

[kclong]

What if the database is many columns, say 25, and I want to search the whole database for the word Jack, but no matter which column it is located, I want to continue to bring in the Account Number and Name which are located in columns A and B?

 

[VoG]

Try

Sub fnd()
Dim rfirst As Range, r As Range, X As String, response As VbMsgBoxResult
X = InputBox("Name to find?")
Set rfirst = Sheets("Sheet1").Cells.Find(What:=X, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If rfirst Is Nothing Then
    MsgBox ("Not found")
    Exit Sub
End If
response = MsgBox("Copy " & Sheets("Sheet1").Range("A" & rfirst.Row).Value & vbTab & Sheets("Sheet1").Range("B" & rfirst.Row).Value & " ?", vbYesNo + vbQuestion)
If response = vbYes Then
    With Sheets("Sheet2")
        .Range("A1").Value = Sheets("Sheet1").Range("A" & rfirst.Row).Value
        .Range("B1").Value = Sheets("Sheet1").Range("B" & rfirst.Row).Value
    End With
    Exit Sub
End If
Set r = Sheets("Sheet1").Cells.FindNext(After:=rfirst)
While (Not rfirst.Address = r.Address)
    response = MsgBox("Copy " & Sheets("Sheet1").Range("A" & r.Row).Value & vbTab & Sheets("Sheet1").Range("B" & r.Row).Value & " ?", vbYesNo + vbQuestion)
    If response = vbYes Then
        With Sheets("Sheet2")
            .Range("A1").Value = Sheets("Sheet1").Range("A" & r.Row).Value
            .Range("B1").Value = Sheets("Sheet1").Range("B" & r.Row).Value
        End With
        Exit Sub
    End If
    Set r = Sheets("Sheet1").Cells.FindNext(After:=r)
Wend
End Sub