Free Microsoft Excel 2013 Quick Reference

Find occurances of a character in string Results

Which function should I use to find the number of times '/' occurs in a single cell. Will the function remain the same if I need to know how many times '/' occurs in an array?


What is the string function to find the second occurence of a character in a



How to find out the position of a Character specified in a particular cell(string) which occurs more than once
'The Demanded Commodity is not in stock' is in A1
the space " " appears six time
what is the position of fifith space " " ?


I'm trying to build a formula to find the position of a duplicate character in a text string for the nth occurance that I specify. Here is an example of the text : 34567-8-9-10-11-12-15-18-24-30-36-42-48-49-50-54-58-62-66-70-76-82-84-86-88-90-92-96-100-107-114 , I would like to find say the 10th dash and return its position within the string.

thank you if you are able to help

Thanks in advance.
I have a macro where I need to get the row number from a
range (like the 11 in "$G$11") becausen I will compare it
with another row number later (if rownum1 < rownum2
then ...)
The way I do it now is:
1 get the position of the first '$' from the right (I made
a function like InStr, except it looks from the right end
of string, not the left end)
2 get the right part of the string for as many chars as
(total length of string - position of first '$' from left)

ie for "$G$11":
1 position of first '$' from right is 3
2 length of string-position=row number length. 5-3=2, so
get "11"
Then I can compare "11" with another row number (like 6 or
I am wondering if there is an easier way to do this, or is
there a built-in command for this? I wanted to use InStr,
but InStr looks for the first occurence of a string from
the left, not right. I can't use right(string1,2) either
because the row number might be "1" or "326" or "4355"
or "65029", where the number of digits change.
Any ideas?
Thanks again.

Please see attached sheet. I can count the number of occurances that a Variable is found in a string but need a formula that will find that variable and sum up only the first set of numbers to the left.



I want to write a formula to find position of all locations of a given character in a string/cell. Find and Search functions give the first occurence of such location.

Eg: If I have "Apple" in A1, I want my formula result as 2,3 if my search string is 'p". FIND("p",A1) will give 1. Search("p",A1) also gives 1.

Can anyone help.


Hi Guys,

Really struggling with a query in excel.

I am trying to use SUMIF to count the occurrences of a 3 character alphanumeric entry of text in a series of cells.

I have a simple version which works however it counts the cells which have that occurrence in not the amount of times that string occurs.

I know it would be better to rewrite the spreadsheet but that is not possible due to certain limitations.

In this example the text in the field is

"UH X4 - 314657 R01 22/02/09 - 314972 R09 03/05/09 - 315627 R01 09/06/09 - 315932 R09 25/06/09"

This is telling me

UH = Unacceptable history
X4 = 4 Jobs have been done to this job
xxxxxx = the job number
XYY = The person working on it
Date, the date the job was completed

I have about 30 other rows similar to this within the column and I need to count all the times R01 and R02 occur in the whole column, not the ammount of cells that occurrence is in.

This is what I am using to cound that column.


This calculates how many Cells R01 appears in however as you can see above R01 appears twice, I need it to count that as 2 not 1.

Also if there is some way I can extract the dates from this field and calculate a mean average between the dates and flag up dates that are 3 weeks apart or less that would be great.

Any help would be appreciated, I'm sorry for rambling on but I'm really stuck on this one.



I have a sheet with columns of data, 2 adjacent columns have data, example below:

Column A Column B Column C
Base Model Model Description
Avalon Toyota Avalon XLS Sedan
Avalon Toyota Avalon XL Sedan
Camry Toyota Camry Hybrid Coupe
Camry Toyota Camry XLE Wagon

What I'd like to do is a find, searching the text string in Column B, for the occurence of the contents in column A, and then return the NEXT word after the found word in column C. I suspect I many need to use a vba function, but lack the skills. Currently I'm using a MID an LEN find formula (below) in Column C, but it's limited to a character count, and I only want to return the next whole word.


This returns the following:
Column A Column B Column C
Avalon Toyota Corp. Avalon XLS Sedan XLS
Avalon Toyota Avalon XL Sedan XL S
Camry Toyota Co. Camry Hybrid Coupe HYBR
Camry Toyota Motors Camry XE Wagon XE W

What I want to return is just the trim level: Hybrid; XLS, XL or XE for example. As you can see, when using the character count, it may also extract into the body style; such as the W in wagon, etc. I've tried variations using RIGHT also, and still seems to be limited by the character count.

Eventually, if it works, in column D I'll concatenate the Column A and D together to return Avalon XLS, etc.

I know there are ways to filter, sort, vlookup, etc, based on all the model types, but those solutions won't work, because the data I'm using isn't toyota cars; not trim levels, and I have a sheet which is 77,000 rows long, by 90 columns wide, and there are over 18,000 unique/distinct values in column B.

I've also considered converting text to columns, which fails because sometimes the 'trim' level is the second word, sometime it's the 10th word; but it ALWAYS follows the model (which is listed solo in column A).




I have a data for ex a;b;c;d in a cell if i find ";" excel formula should
display result as 3 because no of occurence of ";" in a cell is 3.

I need a excel formula to do this help me out.

I am working with a spreadsheet that contains product descriptions. The
descriptions have varying lengths, but all have a "suffix" code of some type
at the end of the description that I would like to eliminate. Here is an
example of the data I'm working with:


In this example, I need to eliminate the " Rfg" in line 1, and the "
Grocery" text in line 2. My hunch is that I need to use a combination of
"FIND" and "LEFT" to basically find the last occurance of "space", then bring
back the leftmost "n" characters based on the position of that last "space".
Can someone help??

Hi all,

I've hit a snag and cannot figure out a workaround.
I am trying to search row by row for any number starting with 425 (the numbers will range from 4250 to 4259) and report a binary result.

say the data looked like this:
A B C D (the columns go out to IC,the rows to 24875!!)
Row1: 0385 / Jack / 4259 / Phil

i have been trying =if(countif(a1:e1),"425?"),1,0), however, it doesnt seem to recognize the wildcard. I have tried using numbers as text and numbers and i get the same result. since the dataset is so large, im trying to automate whatever i can without having to use a nested if(or( to find all the data semi-automatically. any thoughts?

Below is some code. Its supposed to read in all the files in a given directory and then append them all together. But at the 92K rows area i try to add another file and for some reason the "last_row2" variable goes to the value of "2" and I can not figure out why?

note: i could nto paste all the code as there is a 10000 character limitation

Option Base 1
Public bOK As Boolean, baderror As Boolean
Declare Function SetCurrentDirectory Lib "kernel32" Alias "SetCurrentDirectoryA" (ByVal lpPathName As
String) As Long

'Public Const Sheet_Collection_Sheet = "Collection Sheet"

'     Determines the row num of the last nonempty cell begining at x,y
'              Better function........faster!!!!!!!!!1
Function lastrow(iRow As Integer, iCol As Integer, sWkb As String, sWks As String, search_direction As String) As Long
    If search_direction = "down" Then
    lastrow = Workbooks(sWkb).Sheets(sWks).Cells(iRow, iCol).End(xlDown).Row
    Else:  lastrow = Workbooks(sWkb).Sheets(sWks).Cells(Rows.Count, iCol).End(xlUp).Row
    End If
End Function
'     Returns the col num of the right most col begining at x,y
Function ColNumRt(iRow As Long, iCol As Long, sWkb As String, sWks As String, search_direction As String) As Long
    If search_direction = "right" Then
        ColNumRt = Workbooks(sWkb).Sheets(sWks).Cells(iRow, iCol).End(xlToRight).Column
    Else: ColNumRt = Workbooks(sWkb).Sheets(sWks).Cells(iRow, iCol).End(xlToLeft).Column
    End If
End Function
'                     Determines if an array is empty
Function IsArrayEmpty(a As Variant) As Boolean
    IsArrayEmpty = Len(Join(a, "")) = 0
End Function
'     Returns the character equivalent of a col num
Function alphacol(numcol As Long)
If numcol > 0 And numcol < 257 Then
        If numcol > 26 Then
            colchar = Chr(64 + Int((numcol - 1) / 26))
            colchar = colchar & Chr(65 + ((numcol - 1) Mod 26))
        Else: colchar = Chr(65 + ((numcol - 1) Mod 26))
        End If
    End If
alphacol = colchar
End Function
'   Identifies the row or col  where the "NEXT" occurance occurs of
'   a given string.
'Modified from
'the modified version finds the EXACT string and nothing else
Function Find_next_occurance(Rng As Range, TextToFind As String, rowcol As String) As Long
    Dim cl As Range, x As Long
    Find_next_occurance = 0
    For Each cl In Rng
            If cl.Value = TextToFind Then
            'If InStr(1, cl, TextToFind) > 0 Then
            If rowcol = "row" Then
                Find_next_occurance = cl.Row
            ElseIf rowcol = "col" Then
                Find_next_occurance = cl.Column
            End If
                GoTo foundit
            End If
    Next cl

End Function

'     Determines the row num of the last nonempty cell begining at x,y
'              Better function........faster!!!!!!!!!1
Sub Main_Combine_Files_Program()

Dim file_array() As Variant
Dim Path1 As String
Dim Tempfilename As String
Dim tempsheetname As String

Dim CopyFilename As String
Dim x As Long
Dim last_col1 As Long
Dim last_row1 As Long
Dim last_row2 As Long
Dim filename_combinemacro As String

Dim name_error As Boolean
Dim Sheet_Collection_Sheet As String

'Do not display alerts in case there was a problem
Application.DisplayAlerts = False
On Error Resume Next

filename_combinemacro = ThisWorkbook.Name

get_name_of_sheet filename_combinemacro, Sheet_Collection_Sheet, name_error

'MsgBox (" nae is   " & Sheet_Collection_Sheet)

If name_error Then
    MsgBox ("Check the name of the sheet on the main page.  It appears you have input an invalid result.  Program will
now end.")
    GoTo endsub_combinemacro
End If

get_list_of_files_and_path file_array, Path1

'For Z = 1 To UBound(file_array())
'MsgBox (Z & "   " & file_array(Z))
'MsgBox ("stp hereeeeeeeeeeeeeeeeeeeeee")

done = False
x = 1

If UBound(file_array()) > 0 Then
    Set NewBook = Workbooks.Add

    Tempfilename = ActiveWorkbook.Name
    tempsheetname = ActiveSheet.Name
    With Workbooks(Tempfilename).Worksheets(tempsheetname).Columns("A")
    .ColumnWidth = .ColumnWidth * 2
    End With

    Do While Not (done)
    Workbooks.Open FileName:=Path1 & file_array(x)
    CopyFilename = ActiveWorkbook.Name
    MsgBox ("x is " & x)
    MsgBox ("file array x is    " & file_array(x))

    'If user wanted first or last sheet in file then this is where you do that.
    'if user input an actual value then this value is already in
    'the Sheet_Collection_Sheet variable
    If Sheet_Collection_Sheet = "sheetfirstsheet" Then
        Sheet_Collection_Sheet = Workbooks(CopyFilename).Worksheets(1).Name
    ElseIf Sheet_Collection_Sheet = "sheetlastsheet" Then
        Sheet_Collection_Sheet = Workbooks(CopyFilename).Worksheets(Worksheets.Count).Name
    End If

'MsgBox (" sheet name is    " & Sheet_Collection_Sheet)

    last_row1 = lastrow(1, 1, CopyFilename, Sheet_Collection_Sheet, "up")
    MsgBox ("lastrow   " & last_row1 & "   for   " & CopyFilename)
    last_col1 = ColNumRt(1, 1, CopyFilename, Sheet_Collection_Sheet, "right")

    'copy data from file. if its the first file then copy header if not first file then copy data only
    If x = 1 Then
    MsgBox ("in copy 1")
        Workbooks(CopyFilename).Worksheets(Sheet_Collection_Sheet).Range("A1:" & alphacol(last_col1) &
    MsgBox ("in copy NOT 1")
        Workbooks(CopyFilename).Worksheets(Sheet_Collection_Sheet).Range("A2:" & alphacol(last_col1) &
    End If

    'Workbooks(CopyFilename).Worksheets(Sheet_Collection_Sheet).Range("A2:" & last_col1 & last_row1).Copy
    'MsgBox ("stop here")
    If x = 1 Then
    MsgBox ("x is qual to 111111111111111111111111111111111")
        last_row2 = 1
    '*****here is where my error occurs.......after about 92323 rows of data i try to add another file of 5k rows and
    ' for some reason teh last_row2=variable all of a sudden goes to the value of "2"
        last_row2 = lastrow(1, 1, Tempfilename, tempsheetname, "up") + 1
         MsgBox ("lastrow2 is   " & last_row2)
         MsgBox ("lastrow2 anotehr way  " &
Workbooks(Tempfilename).Worksheets(tempsheetname).Range("A" & Rows.Count).End(xlUp).Row)
         MsgBox ("file is " & Tempfilename & "    name sheet is    " & tempsheetname)
    End If

    'MsgBox ("see")
    'MsgBox ("just before paste")
    Workbooks(Tempfilename).Worksheets(tempsheetname).Range("A" & last_row2).PasteSpecial _
                    Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
MsgBox ("just after paste...............")

    'Test to see if you need to jump outof the loop
    If x < UBound(file_array()) Then
    MsgBox ("less than ubound")
    x = x + 1
    Else: done = True
    MsgBox ("greater than ubound")
    End If
Else:  MsgBox ("Array is empty....")
End If
End Sub

I am working with a spreadsheet that contains product descriptions. The
descriptions have varying lengths, but all have a "suffix" code of some type
at the end of the description that I would like to eliminate. Here is an
example of the data I'm working with:


In this example, I need to eliminate the " Rfg" in line 1, and the "
Grocery" text in line 2. My hunch is that I need to use a combination of
"FIND" and "LEFT" to basically find the last occurance of "space", then bring
back the leftmost "n" characters based on the position of that last "space".
Can someone help??

Is there any way of finding how often a particular character occurs in a particular string? I know how to find out whether it occurs at all and if so how far into it, but not how often.

     'Procedure level variables
    Dim lCount As Long 
    Dim lOccur As Long 
    Dim rCell As Range 
    Dim rCell2 As Range 
    Dim rCell3 As Range 
    Dim bFound As Boolean 
    Dim sestej As Long 
    Dim ws As Worksheet 
    For Each ws In ActiveWorkbook.Worksheets 
         'do something
         'Dim strfind4 As String
         'At least one value, from ComboBox1 must be chosen
        If strFind1 & strFind2 & strFind3 = vbNullString Then 
            MsgBox "Izbran ni bil noben kriterij", vbCritical 
            Exit Sub 'Go no further
        ElseIf strFind1 = vbNullString Then 
            MsgBox "A value from " & Label1.Caption _ 
            & " must be chosen", vbCritical 
            Exit Sub 'Go no further
        End If 
         'Clear any old entries
        On Error Resume Next 
        On Error Goto 0 
         'If String variable are empty pass the wildcard character
        If strFind2 = vbNullString Then strFind2 = "*" 
        If strFind3 = vbNullString Then strFind3 = "*" 
         'Set range variable to first cell in table.
        Set rCell = rRange.Cells(1, 1) 
         'Pass the number of times strFind1 occurs
        lOccur = WorksheetFunction.CountIf(rRange.Columns(1), strFind1) 
         'Loop only as many times as strFind1 occurs
        For lCount = 1 To lOccur 
             'Set the range variable to the found cell. This is then also _
            used To start the Next Find from (After:=rCell) 
            Set rCell = rRange.Columns(1).Find(What:=strFind1, After:=rCell, _ 
            LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _ 
            SearchDirection:=xlNext, MatchCase:=False) 
             'Check each find to see if strFind2 and strFind3 occur _
            on the same row. 
            If rCell(1, 2) Like strFind2 And rCell(1, 4) Like strFind3 Then 
                bFound = True 'Used to not show message box for no value found.
                 'Add the address of the found cell and the cell on the _
                same row but 2 columns To the right. 
                ListBox1.AddItem rCell.Value 
                ListBox1.List(ListBox1.ListCount - 1, 1) = rCell.Offset(0, 1).Value 
                ListBox1.List(ListBox1.ListCount - 1, 2) = rCell.Offset(0, 2).Value 
                ListBox1.List(ListBox1.ListCount - 1, 3) = rCell.Offset(0, 3).Value 
                ListBox1.List(ListBox1.ListCount - 1, 4) = rCell.Offset(0, 4).Value 
                ListBox1.AddItem rCell.Address & ":" & rCell(1, 3).Address 
                ListBox1.ControlTipText = "Dvoklikni na naslov celice in ne na besedilo (naslov :$A$2:$A$2)" 
            End If 
            If rCell(1, 2) Like strFind2 And rCell(1, 4) Like strFind3 Then 
                sestej = WorksheetFunction.Sum(rCell(1, 3)) + sestej 
                TextBox1.Text = sestej 
            End If 
        Next lCount 
        If bFound = False Then 'No match
            MsgBox "Zapis s tem kriterijem ne obstaja", vbOKOnly 
        End If 
    Next ws 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
where should i write the code for this form, to loop through all sheets in workbook find data and display them in listbox

I cant manage to do that, it always loops as many times as there are sheets in workbook but doesnt find records from other sheet

ex: 21 saban -this is in sheet1
21 drek -this is in sheet2

then i get results in listbox twice, but from the same sheet
in listbox is:
21 saban
21 saban

Hi all, In summary, I am using the code below to read in each line of the attached CSV file. When opened in Notepad or Textpad or Excel there are 1,139 rows/lines. So you would think there are 1,139 carraige returns.

My code is supposed to read each line of the csv file using Line Input. Lline input will only read a string up to but excluding the paragraph marker - from help file:

The Line Input # statement reads from a file one character at a time until it encounters a carriage return (Chr(13)) or carriage return–linefeed (Chr(13) + Chr(10)) sequence. Carriage return–linefeed sequences are skipped rather than appended to the character string.

    Dim my_string As String 
    Dim iloop As Integer 
    Open "c:test.csv" For Input As #1 
    While Not EOF(1) 
        Line Input #1, my_string 
    MsgBox ("length of line: " & Len(my_string) & Chr(13) & "number of carraige returns: " & InStr(my_string, Chr(13))) 
    Close #1 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
However, the code loops only once... the eof marker is reached on the first line input statement and the ENTIRE file is read into one string. Presumably because it is can not find any chr(13) 's. Testing this proves decisive - the msg box shows zero occurances of chr(13).

This CSV file was generated as part of another process on a Linux machine (I wanted to analyse it in Excel).

Whats wrecking my head is I dont know what the end of line marker is for Linux.... so I cant even do a search and replace for it to make sure that Line Input will work ok....

I have noticed that if I open the csv file in excel and re-save it immediately even without any text changes, the code will work fine next time around, reporting 1139 carraige returns. So it seems excel recognises a Linux carraige return, but Line Input does not.

Any idea's greatly appreciated.



I use this board extensively and I've managed to complete something I've been working on for a while, and I wanted to give something back as a way of saying thanks.

The piece of work gets user input from one userform field and sends the output to another field. During the process it replaces known "words" with known "abbreviations". It's part of a tool to create output for SMS messages that have approved abbreviations (which managers have agreed too).

This first bit of code requires a textfield called txtIssue to exist on a userform called frmSendSMS. This subroutine is triggered everytime the field changes i.e. each time a character is entered or deleted by the user.

Private Sub txtIssue_Change()
    Dim RawText As String
    RawText = frmSendSMS.txtIssue.Value
    'Copy RawText to "Issue" (sheet "SMS" cell b5)
        Worksheets("SMS").range("b5").Value = RawText
    'Run TextFilter to process Glossary
        Call TextFilter(RawText)
    'Copy Filtered RawText to "Issue (Filtered)" (sheet "SMS" cell b6)
        Worksheets("SMS").range("b6").Value = RawText
    'View SMS
    Call viewSMS
End Sub
So each time the txtIssue subroutine, it in turn runs the TextFiler subroutine. When it does this is passes the content of the txtIssue field to the TextFilter as a variable called RawText

The TextFilter then uses a regular expression to do pattern matching. It does this by refering to a worksheet called Glossary. The layout of the Glossary sheet is shown below. It is simply three columns; one has the keyword, the second the abbreviation for the keyword and a description (optional - not used by the subroutine).

TextFilter does this;

1. read txtIssue input as RawText
2. create a regular expression object
3. modify the object to change default matching from first occurrence, to check all occurrences.
4. modify the object to switch off case sensitivity
5. read first row of Glossary sheet
6. Store first value in column "a" as Term
7. Store first value in column "b" as Abbr
8. then use regular expression "b" & Term & "b" to locate all occurances of Term in the string RawText and replace it with Abbr
9. Send the modified RawText which is returned back to the txtIssue subroutine to cell Worksheets("SMS").range("b6").Value
10. then restart loop on the next row down in the Glossary

Private Sub TextFilter(ByRef RawText As Variant)
    'Create a regular expression object
    Set regEx = CreateObject("VBScript.RegExp")
    'Set patterning matching to check all occurances
    regEx.Global = True
    'Set to be case insensitive
    regEx.IgnoreCase = True

    'Loop through rows on the "Glossary" sheet
        TermLoc = "a" & row
        AbbrLoc = "b" & row
        row = row + 1
        Term = StrConv(Worksheets("Glossary").range(TermLoc).Value, VbStrConv.vbLowerCase)
        Abbr = StrConv(Worksheets("Glossary").range(AbbrLoc).Value, VbStrConv.vbLowerCase)
        'Replace all occurances of "Term" with the "Abbreviation"
        'and ingore all partial matches
        regEx.Pattern = "b" & Term & "b"
        RawText = regEx.Replace(RawText, Abbr)
    Loop Until Term = ""
End Sub
This is how the Glossary sheet is laid out.

	A	B	C

1	Term	Abbr.	Description

2	error	err	what the term error means can be written here

3	message	msg	what the term error means can be written here
I hope this is a welcome addition to the knowledge pool.

Michael Gruber

Hi ... I'm a newbie and I hope you can help me out. I've spent several hours trying to find the correct formula to help me analyze a survey. in Excel 2003.

The survey has a series of questions ... 5-1., 5-2., 5-3., etc. and each response is a particular consistent string of characters. I want to total all the different replies to each question and have arranged the questions in column A and the answers in B. I chose the following command:

I believe the SUMPRODUCT should work. It works fine if the entire question string is entered between quotes and if the corresponding longer answer e.g. "John Lennon played with the Beatles" is also used. I want to use wild cards (with only the question number and a unique word in the answer) to make it easier.

I'd appreciate any suggestions as to how to get the wild cards working and if there is a better conditional process other than SUMPRODUCT. I am willing to try it out.

Thanks in advance. I trust the image (HTML code) displays properly below.

******** ******************** src="*********>


I've a large series of workbooks which contain data covering multiple sheets, sometimes over 20 sheets.

I have a code which I obtined from somewhere online (can't remember where) I've modified it a little to fit into my spreadhsheet. The problem is that it won't search beyond a certain point in the document for some reason. I'm not sure if this is a fault in the code, or some other limiting factor. Your help would be much appreciated.

The code I'm using for the search utility is shown below.

Ideally I would be able to just display the data I want when I open the page, but since all the workbooks are different in format and content, it looks like this may be a more manual operation.

'In the Search sheet
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
                        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
     '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
    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("A1:B1").Interior.ColorIndex = 6
    Range("A1").Value = "Occurences of:"
    If Reset = True Then Range("B1").Value = Search
    Range("A1:D2").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
    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
            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
End Sub
Thanks for looking,

I'm only new with VBA so be gentle please.