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
.SortFields.Add Key:=sortcol, SortOn:=xlSortOnValues, Order:=xlDescending
.Header = xlYes
.Apply
End With
End Sub
Sub copysearch()
Dim linkrange As Range, c As Range
Dim namerange As Range
Dim hyp As Hyperlink
Dim hyps As Hyperlinks
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 linkrange = .Range("D13:D32")
Set namerange = .Range("E13:E32")
For Each c In namerange 'Iterates all cells from E13 to E32
c.ClearHyperlinks 'Remove all hyperlinks if there are any
If c <> "" Then 'Make sure to not add hyperlinks on empty cells
c.Hyperlinks.Add c, .Range("D" & c.Row) 'Add a hyperlink based on the value of D.
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
arrColl.Add item, item
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.
