Bonjour,
J'ai créé une fonction il y a maintenant quelques mois qui permet de griser des mots d'un document Word si ceux-ci sont présents dans un fichier Excel.  
 
Sub search()
Dim objexcel As Excel.Application
Dim wbExcel As Excel.Workbook
Dim wsExcel As Excel.Worksheet
 
Set objexcel = CreateObject("Excel.Application" )
 
On Error GoTo fin
 
  '*************************** Recherche du fichier **************************
    If pathFile <> "null" Then
        Set wbExcel = objexcel.Workbooks.Open(pathFile)
        Set wsExcel = wbExcel.Worksheets(1)
        wsExcel.name = nameFile
    Else
        Set wbExcel = objexcel.Workbooks.Add
        wbExcel.SaveAs ("C:\monDossier\terms.xls" )
        Set wsExcel = wbExcel.Worksheets(1)
        wsExcel.name = "terms"
        MsgBox "A file named terms.xls was created. Terms will be saved into C:\monDossier\terms.xls."
    End If
    '*************************************************************************
 
objexcel.ActiveWorkbook.ActiveSheet.Cells("1" ).Select
Set wsExcel = wbExcel.Worksheets(1)
Set sheet = objexcel.ActiveWorkbook.ActiveSheet
 
Selection.StartOf Unit:=wdStory
 
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
 
 
'************ Recherche des termes déjà stockés ***************
While objexcel.ActiveCell.Offset(cpt, 0).Value <> ""
    With Selection.Find
            .ClearFormatting
            .text = objexcel.ActiveCell.Offset(cpt, 0).Value
             
    'On Error GoTo fin
        With .Replacement
            .ClearFormatting
            .text = objexcel.ActiveCell.Offset(cpt, 0).Value
            .Style = "Normal"
            .Font.Color = wdColorGray625
        End With
        .Execute Replace:=wdReplaceAll, Format:=True, MatchCase:=False, MatchWholeWord:=True, Wrap:=wdFindContinue
    End With
    cpt = cpt + 1
Wend
 
    MsgBox "The search is finished."
    wbExcel.Close SaveChanges:=True
    objexcel.Quit
    Set wsExcel = Nothing
    Set wbExcel = Nothing
    Set objexcel = Nothing
Exit Sub
 
fin:
MsgBox "A problem occur please contact the administrator of the system"
    wbExcel.Close SaveChanges:=True
    objexcel.Quit
    Set wsExcel = Nothing
    Set wbExcel = Nothing
    Set objexcel = Nothing
   
End Sub
 
Cette fonction marche bien mais étant donné que le volume de mots dans le fichier Excel grandit à vive allure,le temps de traitement des fichiers pour rechercher les mots déjà stockés devient assez long.
En tant que pros de la programmation, pouvez-vous me dire quel changement serait susceptible d'améliorer la complexité de mon algorithme?
 
Merci d'avance.

bonjour,
 
Dans la partie 3 supprimer les set redondants (je crois)
objexcel.ActiveWorkbook.ActiveSheet.Cells("1" ).Select  
Set wsExcel = wbExcel.Worksheets(1)  
Set sheet = objexcel.ActiveWorkbook.ActiveSheet  
 
mettre à la place :
 
i = wsExcel.Cells(65535, 1).End(xlUp).Row
 
remplacet la boucle while par :
 
 
For k = 1 to i
...
.text = wsExcel.Cells(k,1)  
...
.text = wsExcel.Cells(k,1)
...  
Next
 
... l'important étant de virer tous les offset aussi consommateurs de temps que des select !
 
...Et croiser les doigts !    
 
Sinon l'idéal serait de stocker le Range(Cells(1,1),Cells(i,1)) dans un Array et refermer le classeur : L'accès à un Array est au moins 100 x plus rapide que l'accès au Range.
Dim Tablo()
 
...
i = wsExcel.Cells(65535, 1).End(xlUp).Row
Tablo = Range(Cells(1,1),Cells(i,1))
 
For k = 1 to i
...
.text = Tablo(k,1)  
...
.text = Tablo(k,1)  
...
Next
 
...Et croiser les doigts encore plus fort !      
 
(je ne suis pas arrivé à faire fonctionner cette macro !    
 
A+

ok, je vais voir tout ça.
Merci beaucoup

De manière plus générale voir aussi [url=http://fordom.free.fr/tuto/OPTIMISATION.htm[#0000ff]]ici[/url]