Question : script a find of keyword and display results in excel spreadsheet

Hi Experts,

I want to do a script/macro in excel where it searches for a key word and then displays it in a cell.

Currently I have huge database of contacts and I want to run a search for key word school and then display it in a field. So if a cell High school, north school, Saint Primary School etc it will copy the entire contents of this cell and past it in another cell. All the results can be pasted in one cell.

Any help would be greatly appreciated.

Thanks

Jedi

Answer : script a find of keyword and display results in excel spreadsheet

This code returns the string to C1 (or to a VBA variable). It lets you change the column to search

See attached file

hth

Dave

                       
         
           
             1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:

           
           
             Option Explicit

Const strText As String = "school"

Sub ColSearch_DelRows()
    Dim rng1 As Range
    Dim cel As Range

    Dim strFirstAddress As String
    Dim lAppCalc As Long
    Dim strTmp As String
 

    'Get working range from user
    On Error Resume Next
    Set rng1 = Application.InputBox("Please select range to search for " & strText, "User range selection", Selection.Address(0, 0), , , , , 8)
    On Error GoTo 0
    If rng1 Is Nothing Then Exit Sub



    With Application
        lAppCalc = .Calculation
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With


    Set cel = rng1.Find(strText, rng1.Cells(rng1.Cells.Count), xlValues, xlPart, xlByRows, xlNext, False)

    If Not cel Is Nothing Then
        strFirstAddress = cel.Address
        strTmp = cel.Value
        Do
            Set cel = rng1.FindNext(cel)
         If strFirstAddress <> cel.Address Then strTmp = strTmp & vbCrLf & cel.Value
        Loop While strFirstAddress <> cel.Address
    End If
    

    With Application
        .ScreenUpdating = True
        .Calculation = lAppCalc
    End With
    
    MsgBox strTmp
    [c1].Value = strTmp

End Sub

           
         