Solved: SearchWord Help

[Pooja]

Hi,

I used the SearchWord add-in. It's really awesome!

I just have one question - currently, I can only search for one item at a time. Is it possible to allow it to search for multiple items at the same time? I would like to search for multiple product IDs at the same time and then get them listed in the SearchWord sheet.

For example, column A has product IDs from ABC100 to ABC500. I would like to search for ABC162, ABC272, and ABC 500... etc. and have just those rows displayed in the SearchWord sheet.

Thanks in advance for helping,

Pooja

[Ago]

im just guessing here, but maybe we need to know what the searchword add-in is?
perhaps you could be kind enough to tell us/show us?

[Pooja]

Oops sorry. SearchWord is one of the add-ins listed in VBAExpress.com (kb_id=780). I tried to add a link in my earlier post but was unable to since I am a new member.

[Aussiebear]

Here is the code as written by mdmackillop
[VBA]
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$1" Then
Application.Run "SearchWord.xla!FindAll", Target.Text, "False"
Cells(1, 2).Select
End If
End Sub

'In ThisWorkbook of the Add-In
Option Explicit
Private Sub Workbook_AddinInstall()
On Error Resume Next
Application.CommandBars("Tools").Controls("Search &word").Delete
On Error Goto 0
With Application.CommandBars("Tools").Controls.Add
.Caption = "Search &word"
.Tag = "Search word"
.OnAction = "'" & ThisWorkbook.Name & "'!Search.DoFindAll"
End With
MsgBox "'Search word' option added to Tools menu"
End Sub

Private Sub Workbook_AddinUninstall()
On Error Resume Next
Application.CommandBars("Tools").Controls("Search &word").Delete
End Sub

'In a module of the Add-In
Option Compare Text
Option Explicit

Public Sub DoFindAll()
FindAll "", "True"
End Sub

Public Sub FindAll(Search As String, Reset As Boolean)

Dim WB As Workbook
Dim WS As Worksheet
Dim Cell As Range
Dim Prompt As String
Dim Title As String
Dim FindCell() As String
Dim FindSheet() As String
Dim FindWorkBook() As String
Dim FindPath() As String
Dim FindText() As String
Dim Counter As Long
Dim FirstAddress As String
Dim Path As String

If Search = "" Then
Prompt = "What do you want to search for in the worbook: " & _
vbNewLine & vbNewLine & Path
Title = "Search Criteria Input"
Search = InputBox(Prompt, Title, "Enter search term")
If Search = "" Then
Goto Cancelled
End If
End If

Application.EnableEvents = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False

On Error Goto Cancelled

Set WB = ActiveWorkbook
For Each WS In WB.Worksheets
If WS.Name <> "SearchWord" Then
'Search whole sheet
'With WB.Sheets(WS.Name).Cells
'***********************************
'Alternative to search single column
With WB.Sheets(WS.Name).Range("B:B")
'***********************************
Set Cell = .Find(What:=Search, LookIn:=xlValues, LookAt:=xlPart, _
MatchCase:=False, SearchOrder:=xlByColumns)
If Not Cell Is Nothing Then
FirstAddress = Cell.Address
Do
Counter = Counter + 1
ReDim Preserve FindCell(1 To Counter)
ReDim Preserve FindSheet(1 To Counter)
ReDim Preserve FindWorkBook(1 To Counter)
ReDim Preserve FindPath(1 To Counter)
ReDim Preserve FindText(1 To Counter)
FindCell(Counter) = Cell.Address(False, False)
FindText(Counter) = Cell.Text
FindSheet(Counter) = WS.Name
FindWorkBook(Counter) = WB.Name
FindPath(Counter) = WB.FullName
Set Cell = .FindNext(Cell)
Loop While Not Cell Is Nothing And Cell.Address <> FirstAddress
End If
End With
End If
Next

'If no result found, reset properties and exit sub
If Counter = 0 Then
MsgBox Search & " was not found.", vbInformation, "Zero Results For Search"
'Clear old results if required
'Range("A3", ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell)).ClearContents
'**********************************
Goto Cancelled
End If

'Add SearchWord sheet if not present
On Error Resume Next
Sheets("SearchWord").Select
If Err <> 0 Then
ThisWorkbook.Sheets("SearchWord").Copy Before:=ActiveWorkbook.Worksheets(1)
End If

On Error Goto Cancelled

'Clear old data and then format results page as required
Range("A3", ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell)).ClearContents
Range("A1:B1").Interior.ColorIndex = 6
Range("A1").Value = "Occurences of:"
If Reset = True Then Range("B1").Value = Search
Range("A12").Font.Bold = True
Range("A2").Value = "Location"
Range("B2").Value = "Cell Text"
Range("A1:B1").HorizontalAlignment = xlLeft
Range("A2:B2").HorizontalAlignment = xlCenter
With Columns("A:A")
.ColumnWidth = 14
.VerticalAlignment = xlTop
End With
With Columns("B:B")
.ColumnWidth = 50
.VerticalAlignment = xlCenter
.WrapText = True
End With

'Add hyperlinks and results to spreadsheet
For Counter = 1 To UBound(FindCell)
ActiveSheet.Hyperlinks.Add Anchor:=Range("A" & Counter + 2), _
Address:="", SubAddress:="'" & FindSheet(Counter) & "'" & "!" & FindCell(Counter), _
TextToDisplay:=FindSheet(Counter) & " - " & FindCell(Counter)
Range("B" & Counter + 2).Value = FindText(Counter)

'Add text from offset columns; probably not
'appropriate with whole sheet search
Range("C" & Counter + 2).Value = _
Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, 1)
Range("D" & Counter + 2).Value = _
Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, 2)
'*********************************************
Next Counter

'Find search term on results page and colour text
ColourText

Cancelled:

Set WB = Nothing
Set WS = Nothing
Set Cell = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

Sub ColourText()
Dim Strt As Long, x As Long, i As Long
Columns("B:B").Characters.Font.ColorIndex = xlAutomatic
For i = 3 To Range("B" & Rows.Count).End(xlUp).Row
x = 1
Do
Strt = InStr(x, Range("B" & i), [B1], 1)
If Strt = 0 Then Exit Do
Range("B" & i).Characters(Start:=Strt, _
Length:=Len([B1])).Font.ColorIndex = 7
x = Strt + 1
Loop
Next
End Sub
[/VBA]

[Bob Phillips]

Sent my Excel into an unbreakable loop, so can't help.

[mdmackillop]

Sorry about that Bob.

Pooja,
This version will split comma separated text entered into B1. It can be further adjusted to use a Range source if required.

[vba]
Public Sub FindAll(Search As String, Reset As Boolean)
Dim WB As Workbook
Dim WS As Worksheet
Dim Cell As Range
Dim Prompt As String
Dim Title As String
Dim FindCell() As String
Dim FindSheet() As String
Dim FindWorkBook() As String
Dim FindPath() As String
Dim FindText() As String
Dim Counter As Long
Dim FirstAddress As String
Dim Path As String
Dim strSearch As Variant
Dim strS As Variant
Dim sFound As Long
If Search = "" Then
Prompt = "What do you want to search for in the worbook: " & _
vbNewLine & vbNewLine & Path
Title = "Search Criteria Input"
Search = InputBox(Prompt, Title, "Enter search term")
If Search = "" Then
GoTo Cancelled
End If
End If
'Split search terms
strSearch = Split(Search, ",")
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False
On Error GoTo Cancelled
Set WB = ActiveWorkbook
For Each strS In strSearch
For Each WS In WB.Worksheets
If WS.Name <> "SearchWord" Then
'Search whole sheet
'With WB.Sheets(WS.Name).Cells
'***********************************
'Alternative to search single column
With WB.Sheets(WS.Name).Range("B:B")
'***********************************
Set Cell = .Find(What:=Trim(strS), LookIn:=xlValues, LookAt:=xlPart, _
MatchCase:=False, SearchOrder:=xlByColumns)
If Not Cell Is Nothing Then
FirstAddress = Cell.Address
Do
sFound = 1
Counter = Counter + 1
ReDim Preserve FindCell(1 To Counter)
ReDim Preserve FindSheet(1 To Counter)
ReDim Preserve FindWorkBook(1 To Counter)
ReDim Preserve FindPath(1 To Counter)
ReDim Preserve FindText(1 To Counter)
FindCell(Counter) = Cell.Address(False, False)
FindText(Counter) = Cell.Text
FindSheet(Counter) = WS.Name
FindWorkBook(Counter) = WB.Name
FindPath(Counter) = WB.FullName
Set Cell = .FindNext(Cell)
Loop While Not Cell Is Nothing And Cell.Address <> FirstAddress
End If
End With
End If
Next
If sFound = 0 Then
MsgBox Search & " was not found.", vbInformation, "Zero Results For Search"
End If
sFound = 0
Next
'If no result found, reset properties and exit sub
If Counter = 0 Then
MsgBox Search & "No search items were found.", vbInformation, "Zero Results For Search"
'Clear old results if required
'Range("A3", ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell)).ClearContents
'**********************************
GoTo Cancelled
End If
'Add SearchWord sheet if not present
On Error Resume Next
Sheets("SearchWord").Select
If Err <> 0 Then
ThisWorkbook.Sheets("SearchWord").Copy Before:=ActiveWorkbook.Worksheets(1)
End If
On Error GoTo Cancelled
'Clear old data and then format results page as required
Range("A3", ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell)).ClearContents
Range("A1:B1").Interior.ColorIndex = 6
Range("A1").Value = "Occurences of:"
If Reset = True Then Range("B1").Value = Search
Range("A12").Font.Bold = True
Range("A2").Value = "Location"
Range("B2").Value = "Cell Text"
Range("A1:B1").HorizontalAlignment = xlLeft
Range("A2:B2").HorizontalAlignment = xlCenter
With Columns("A:A")
.ColumnWidth = 14
.VerticalAlignment = xlTop
End With
With Columns("B:B")
.ColumnWidth = 50
.VerticalAlignment = xlCenter
.WrapText = True
End With
'Add hyperlinks and results to spreadsheet
For Counter = 1 To UBound(FindCell)
ActiveSheet.Hyperlinks.Add Anchor:=Range("A" & Counter + 2), _
Address:="", SubAddress:="'" & FindSheet(Counter) & "'" & "!" & FindCell(Counter), _
TextToDisplay:=FindSheet(Counter) & " - " & FindCell(Counter)
Range("B" & Counter + 2).Value = FindText(Counter)
'Add text from offset columns; probably not
'appropriate with whole sheet search
Range("C" & Counter + 2).Value = _
Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, 1)
Range("D" & Counter + 2).Value = _
Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, 2)
'*********************************************
Next Counter
'Find search term and colour text
ColourText
Cancelled:
Set WB = Nothing
Set WS = Nothing
Set Cell = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

Sub ColourText()
Dim Strt As Long
Dim x As Long
Dim i As Long
Dim strSearch As Variant
Dim strS As Variant
'Split search terms
strSearch = Split(Range("B1"), ",")
Columns("B:B").Characters.Font.ColorIndex = xlAutomatic

For Each strS In strSearch
For i = 3 To Range("B" & Rows.Count).End(xlUp).Row
x = 1
Do
Strt = InStr(x, Range("B" & i), Trim(strS), 1)
If Strt = 0 Then Exit Do
Range("B" & i).Characters(Start:=Strt, _
Length:=Len(Trim(strS))).Font.ColorIndex = 7
x = Strt + 1
Loop
Next
Next
End Sub
[/vba]

[Pooja]

WOW! MD. That was quick. This is exactly what I was looking for.

Thank you, thank you, thank you.

Pooja

[Bob Phillips]

Sorry about that Bob.

What was the cause?

[mdmackillop]

I've used the originasl code for years with no problems. I managed to cause a loop by searching for a space, but I don't imagine you tried that.

[Aussiebear]

Can you amend the KB item MD?

[mdmackillop]

I'll do that shortly.
Thanks Ted.

[Pooja]

MD, Just one more question...

Is there a way I can replace
MsgBox Search & " was not found.", vbInformation, "Zero Results For Search"

and have it just add another row in the SearchWord sheet with the search query and "Not Found" next to it.

It would be really helpful in cases where you would like to see the search terms that did not display any results.

Thanks so much for helping with this.

Pooja

[mdmackillop]

Simpler to write it to another location
[VBA]
If sFound = 0 Then
Cells(1, "G") = "Zero Results"
Set tgt = Cells(Rows.Count, "G").End(xlUp).Offset(1)
tgt.Value = Search
MsgBox Search & " was not found.", vbInformation, "Zero Results For Search"
End If
[/VBA]

[mdmackillop]

If you're are looking for Product IDs in the spreadsheets, I suspect this code is overcomplicated, as it was designed to search text within strings. What is your actual requirement. Can you post a sample of your workbook?