[Excel 2010] Performance issues scanning external documents for text

Hey guys,
i need ur help in order to solve a problem with my code.
The goal is, starting from a compiled table in excel, to scan a single column and find, for each cell value, a match in the documents contained in a specific folder.
The code i wrote works but i have encountered many problems with the performance of the execution.
The code:

• Read the entire 3rd column and populate a collection
• When the excel reading is done it pass to the file management opening each one and searching it for each keyword previously stored in the collection
• When done with files search the control pass again to the excel in order to update an adiacent column with the search results

Now about the numbers: i have to search around 8-10 thousand values in about 800-1.000 word files.
The execution time, in seconds, is around

Formula:

values * documents / 12

, for the specific case we're talking of 4 days of runtime, lol
Any suggestion about what to use (structures, search methods, etc..) to improve timewise?

Here the code:

Function test()

    Dim elencoPartizioni As New Collection
    Dim tempPartizione As CPartizione
    Dim oWordDoc, oWordApp, rngStory As Object
    Dim searchPattern, fileExtensionPattern, sourceFolder, filePath, sFileName, searchResults As String
    Dim idRow As Long
    Dim startTime, endTime As Date
    
    
    sourceFolder = "C:\Users\itals007\Desktop\note\"
    fileExtensionPattern = "*.doc?"
    filePath = Dir$(sourceFolder & fileExtensionPattern)
    Set oWordApp = CreateObject("Word.Application")
    oWordApp.Visible = False
    startTime = Now
    
    idRow = 8
    While Cells(idRow, 3).value <> ""
        
        Set tempPartizione = New CPartizione
        tempPartizione.nomePartizione = LCase(Cells(idRow, 3).value)
        On Error Resume Next
        elencoPartizioni.Add tempPartizione, tempPartizione.nomePartizione
        
        idRow = idRow + 1
    
    Wend
    
'*************************************************************************************
    
    While filePath <> ""
        
        On Error GoTo errorHandling
        sFileName = sourceFolder & filePath
        Set oWordDoc = oWordApp.Documents.Open(sFileName)
        
        Dim iPartizione As CPartizione
        
        For Each iPartizione In elencoPartizioni
            
            If LCase(Left(oWordDoc.Name, InStrRev(oWordDoc.Name, ".") - 1)) = LCase(iPartizione.nomePartizione) Then
            
                iPartizione.presenzaNotaOperativa = "Presenti"
                iPartizione.elencoMatchNoteOperative.Add oWordDoc.Name
                        
            End If
            
            For Each rngStory In oWordDoc.StoryRanges

                With rngStory.Find
                
                    .Text = iPartizione.nomePartizione
                    .Wrap = 1
                    .Execute
                
                    If .found And iPartizione.presenzaNotaOperativa <> "Presenti" Then
                    
                        iPartizione.elencoMatchNoteOperative.Add oWordDoc.Name
                        iPartizione.presenzaNotaOperativa = "Parziali"
                        Exit For
                    
                    End If
                
                End With
            
            Next
        
        Next
        
        oWordDoc.Close
        filePath = Dir$()
        
errorHandling:
            
        If Err.Number <> 0 Then
            
            MsgBox "Errore", vbCritical
            
        End If

    Wend
    
    oWordApp.Quit
    Set oWordDoc = Nothing
    Set oWordApp = Nothing
    
    idRow = 8
    While Cells(idRow, 3).value <> ""
    
        Cells(idRow, 2).ClearComments
        
        If elencoPartizioni.Item(LCase(Cells(idRow, 3).value)).presenzaNotaOperativa = "" Then
        
            Cells(idRow, 2).value = "Non presenti"
        
        Else
        
            Cells(idRow, 2).value = elencoPartizioni.Item(LCase(Cells(idRow, 3).value)).presenzaNotaOperativa
            Cells(idRow, 2).AddComment elencoPartizioni.Item(LCase(Cells(idRow, 3).value)).elencoMatchNote
            Cells(idRow, 2).Comment.Shape.TextFrame.AutoSize = True
        
        End If
            
        idRow = idRow + 1
    
    Wend
    
    endTime = Now
    
    MsgBox "Esecuzione in " & DateDiff("s", startTime, endTime) & " s"
    
End Function