# Document "Search Engine" in Excel

I've created a somewhat "Brute-force search engine" based on a document's filename, as well as an additional keyword that describes the said document. I had to make one as my company's resources are a mess and not fully structured, so it's tough to search for a document using just the regular Windows search tool.

What I first did is to simply extract the filepath of all documents using CMD and DIR, and output it to a csv file which I processed. Then, using an excel formula, extract the filename from the path and remove the filetype as well. I've added an extra column for the keywords portion, which is split via commas.

Once a search is initiated, the search term is broken down to each individual words via spaces. This goes the same for the filename, and keywords. After that, a simple for loop just iterates each word and see if's a match. If it is, a counter is added. Once done, the data is copied onto a temporary sheet.

After checking all available filepaths and moving the matched result on the temporary sheet, I sort them based on the counter, so that the highest match goes on top. Then, I copy the results (including the path) to the main sheet with the searchbox, display the results, and add a hyperlink so that it can be clicked.

Sub Searchresult()
Dim x As Range, y As Long, count As Long, i As Integer, j As Integer, k As Integer, l As Integer
Dim names() As Variant, namesdup() As Variant
Dim search() As String, keyword() As String, namesraw() As String, searchval As String
Dim result As String
Dim tbl As ListObject, sortcol As Range, lrow As Long, lrow2 As Long

OptimizeVBA True 'Makes processing this a lot faster

searchval = Worksheets("Sheet1").Range("E8").Value 'Gets the searchbox text
With Worksheets("Sheet3") 'Prep for placing results in table.
Set tbl = .ListObjects("tblSearch")
Set sortcol = .Range("tblSearch[sort]")
tbl.DataBodyRange.ClearContents
End With

With Worksheets("Sheet2")
search = Split(Trim(searchval), " ") 'split search terms via spaces
lrow2 = .Cells(Rows.count, 1).End(xlUp).Row
For Each x In Range("A2:A" & lrow2) 'Iterate all values in Sheet2
count = 0
lrow = Worksheets("Sheet3").Cells(Rows.count, 1).End(xlUp).Row + 1 'get the last row in Sheet2
keyword() = Split(.Range("d" & x.Row), ",") ' split keywords via comma
namesraw() = Split(Replace(Replace(Replace(Replace(Replace(.Range("c" & x.Row), "-", " "), "(", ""), ")", ""), "'", ""), "_", " "), " ") 'splits names via spaces, deleting any unwanted characters

'This section converts the String array from above to a Variant array
ReDim namesdup(LBound(namesraw) To UBound(namesraw))
Dim index As Long
For index = LBound(namesraw) To UBound(namesraw)
namesdup(index) = namesraw(index)
Next index
'end section

names() = RemoveDupesColl(namesdup())
'We need to remove duplicates from the name search, as it affects accuracy.
'For example, if you search for something that has the word "loc", the filename that repeats this word multiple times will get top results.

'//SEARCH FUNCTION STARTS HERE
'This first part will compare each word typed in the searchbox form each word in the keywords column in Sheet2.
For i = LBound(keyword) To UBound(keyword) 'Iterate the number of keywords in a given row
For j = LBound(search) To UBound(search) 'Iterate the number of words in the searchbox

If UCase(search(j)) Like "*" & UCase(keyword(i)) & "*" Or UCase(keyword(i)) Like "*" & UCase(search(j)) & "*" Then 'compare search term and keyword
Worksheets("Sheet3").Range("A" & lrow, "B" & lrow).Value = .Range("A" & x.Row, "B" & x.Row).Value 'Copy A & B to Sheet3.
count = count + 1
Worksheets("Sheet3").Range("C" & lrow).Value = count 'Put a count on Sheet3
Worksheets("Sheet3").Range("D" & lrow).Value = .Range("E" & x.Row).Value 'Copy D to Sheet3
End If

Next
Next

For k = LBound(names) To UBound(names) 'Iterate the number of names that were split from the document name.
For l = LBound(search) To UBound(search)  'Iterate the number of words in the searchbox
If Len(names(k)) <= 3 And Len(names(k)) > 1 Then 'Prevents getting top results for being part of a long word, for ex: the word LOC will be found on all words that has it, like "LOCATION".
If UCase(search(l)) = UCase(names(k)) Or UCase(names(k)) = UCase(search(l)) Then 'If it's a short word, it must be the same as the search term
Worksheets("Sheet3").Range("A" & lrow, "B" & lrow).Value = .Range("A" & x.Row, "B" & x.Row).Value
count = count + 1
Worksheets("Sheet3").Range("C" & lrow).Value = count
Worksheets("Sheet3").Range("D" & lrow).Value = .Range("E" & x.Row).Value
End If
Else
If (UCase(search(l)) Like "*" & UCase(names(k)) & "*" Or UCase(names(k)) Like "*" & UCase(search(l)) & "*") And Len(names(k)) > 2 And Len(search(l)) > 2 Then  'compare search term and document name
Worksheets("Sheet3").Range("A" & lrow, "B" & lrow).Value = .Range("A" & x.Row, "B" & x.Row).Value
count = count + 1
Worksheets("Sheet3").Range("C" & lrow).Value = count
Worksheets("Sheet3").Range("D" & lrow).Value = .Range("E" & x.Row).Value
End If
End If
Next
Next
'//SEARCH FUNCTION ENDS HERE

Next x

End With

With tbl.Sort 'sort everything based on count to get best result on top
.SortFields.Clear
.Apply
End With

End Sub

Sub copysearch()
Dim linkrange As Range, c As Range
Dim namerange As Range

With Worksheets("Sheet1")
Worksheets("Sheet3").Range("A2:D21").Copy 'Copy the first 20 results
.Range("D13").PasteSpecial Paste:=xlPasteValues 'and paste them on Sheet1
Application.CutCopyMode = False

Set namerange = .Range("E13:E32")

For Each c In namerange 'Iterates all cells from E13 to E32
If c <> "" Then 'Make sure to not add hyperlinks on empty cells
If .Range("G" & c.Row).Value = True Then 'Check if G value is True
.Range("E" & c.Row).Font.Color = vbWhite 'Link is valid, so it's colored white
Else
.Range("E" & c.Row).Font.Color = vbRed 'Link is not valid, colored Red, needs updating.
End If
End If
Next

.Range("E13:E32").Font.Underline = False
.Range("E13:E32").Font.name = "Cambria"

End With

OptimizeVBA False

End Sub

Sub OptimizeVBA(isOn As Boolean) 'Optimize VBA by not running calculations, events, and updates up until Macro is done. Found online.
Application.Calculation = IIf(isOn, xlCalculationManual, xlCalculationAutomatic)
Application.EnableEvents = Not (isOn)
Application.ScreenUpdating = Not (isOn)
End Sub

Function RemoveDupesColl(MyArray As Variant) As Variant 'Online code to remove any duplicates in an array.
'DESCRIPTION:  Removes duplicates from your array using the collection method.
'NOTES:  (1)   This function returns unique elements in your array, but
'              it converts your array elements to strings.
'SOURCE: https://wellsr.com
'-----------------------------------------------------------------------
Dim i As Long
Dim arrColl As New Collection
Dim arrDummy() As Variant
Dim arrDummy1() As Variant
Dim item As Variant
ReDim arrDummy1(LBound(MyArray) To UBound(MyArray))

For i = LBound(MyArray) To UBound(MyArray) 'convert to string
arrDummy1(i) = CStr(MyArray(i))
Next i
On Error Resume Next
For Each item In arrDummy1
Next item
Err.Clear
ReDim arrDummy(LBound(MyArray) To arrColl.count + LBound(MyArray) - 1)
i = LBound(MyArray)
For Each item In arrColl
arrDummy(i) = item
i = i + 1
Next item
RemoveDupesColl = arrDummy
End Function


Everything is working as intended, though I believe that the code can be further optimized. Please note that I only dabble at VBA and had some experience with VB.Net but am not really a programmer. However, I understand formatting so I still made sure that my coding can still be understood. Comments are added everywhere as I am only a temp in the company and would like to pass it on to someone else just in case..

My difficulties when I started this out:

• Singular/Plural terms: That's why there's an "Or" statement that inverts the variables in the "Like" statement as a resolution.
• 2-3 letter words being found inside bigger words: As we're using acronyms or shortcuts, there are times that there are results that are being found that's not really related to what's supposed to show. So an additional If statements were added specifically for the short words.
• Repeating words in filenames: For some reason, there are filenames that repeat the same word multiple times (The acronyms), and it skews the top result as it matches multiple times. I've used an online code to remove the duplicates via collection method. Hence, there was a need to convert the array to a Variant.
• Opening write-protected documents: Sadly, this wasn't fixed, but basically a Word popup when asking to open as read only does not show on top of the Excel program. Excel meanwhile, is unresponsive until the popup box was answered. Wait too long, and an OLE error will show up. A workaround to this one is to have another Word program open, and the popup will show there.
• @Comintern As the codes were sourced online, I wasn't sure if I have to really put it in, but if that's required, I've added it in now. Nov 29, 2018 at 1:30
• Thanks. The other question I have is what you're referring to with the "Word popup when asking to open as read only". I didn't catch any references in there that would indicate that you're automating Word. Is that what the hyperlinks target? (I think the Z-ordering is a Windows 10 "feature" - i.e. bug) Nov 29, 2018 at 1:36
• Yes, the hyperlink also targets Word (.docx) files, as well as PDF, excel files, etc. The other files are opened without issues, and Word documents will open fine too as long as they're not write-protected. Write-protected, meaning it prompts for a password upon opening the file, yet also offers Read Only mode. Nov 29, 2018 at 1:40
• I've experimented with this, and as long as Word does not prompt any popup box, it will be fine. Changing the file property to Read Only will also work, but the documents are updated on a daily basis, so passwords are used as protection instead. Also we're using Windows 7. Nov 29, 2018 at 1:42
• Using dictionaries would greatly simplify and speed up your code. Regex would be best but it can be complicated. Nov 29, 2018 at 3:06