Krdytkyu

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.