Microsoft 365 Recherche dans fichier excel dans un répertoire

 while dir<>""
     set variables =objet
     Set variables= nothing : doevent ' je librairie la mémoire et je rentre la windows.

 with workbooks.open( fichier)
          If .sheet("toto").range("A1")="titi" then
          En if
         .close
End with
Doevent

    ' ---- Nettoyage de cache plus fort toutes les 500 itérations ----
        If (compte Mod 500) = 0 Then
            Application.CalculateFullRebuild
            DoEvents
        End If

    Wend

Option Explicit
Const Feuil1$ = "DOVE"
Const Feuil2$ = "Communication"
Const col1% = 1 'colonne A
Const col2% = 6 'colonne F
Const crit1$ = "Véhicule :"
Const crit2$ = "Vin :"
Const crit3$ = "Battery Identification Number :"
Const crit4$ = "<- 62 F0 29*"
Dim fichier$, lig&, trouve&

Sub Recherche()
Dim t, chemin$, form$, compte
'On Error Resume Next
t = Timer
chemin = ThisWorkbook.Path & "\REPERTOIRE_FICHIERS" & "\"
fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier
lig = 3
Application.ScreenUpdating = True
Rows(lig & ":" & Rows.Count).ClearContents 'RAZ
While fichier <> ""
    compte = compte + 1
    'Application.StatusBar = compte & " " & fichier 'prend beaucoup de temps

    form = "'" & chemin & "[" & fichier & "]" & Feuil1 & "'!"
    Formule form, col1, crit1, lig
    Formule form, col1, crit2, lig
    Formule form, col1, crit3, lig

    form = "'" & chemin & "[" & fichier & "]" & Feuil2 & "'!"
    Formule form, col1, crit4, lig

    If trouve = 1 Then lig = lig + 1

    fichier = Dir 'fichier suivant
    trouve = 0
Wend
MsgBox Timer - t
End Sub

Sub Formule(form$, col%, crit$, lig&)
Dim f$, v
'On Error Resume Next
f = "MATCH(""" & crit & """," & form & "R1C" & col & ":R10000C" & col & ",0)"
v = ExecuteExcel4Macro(f)
If IsNumeric(v) Then
    trouve = 1
    Cells(lig, 1) = fichier 'retourne le nom du fichier
    If crit = crit1 Then Cells(lig, 2) = ExecuteExcel4Macro(form & "R" & v & "C" & col + 1) 'retourne la valeur du Véhicule
    If crit = crit2 Then Cells(lig, 3) = ExecuteExcel4Macro(form & "R" & v & "C" & col + 1) 'retourne la valeur du Vin
    If crit = crit3 Then Cells(lig, 4) = ExecuteExcel4Macro(form & "R" & v & "C" & col + 1) 'retourne la valeur du BIN

    If crit = crit4 Then Cells(lig, 5) = ExecuteExcel4Macro(form & "R" & v & "C" & col) 'retourne la valeur de la trame 62 F0 29
End If
End Sub

Option Explicit
Const Feuil1$ = "DOVE"
Const Feuil2$ = "Communication"
Const col1% = 1 'colonne A
Const col2% = 6 'colonne F
Const crit1$ = "Véhicule :"
Const crit2$ = "Vin :"
Const crit3$ = "Battery Identification Number :"
Const crit4$ = "<- 62 F0 29*"
Dim fichier$, lig&, trouve&

Sub Recherche()
    Dim t, chemin$, form$, compte&
    Dim wb As Workbook, ws As Workbook
 
    t = Timer
    chemin = "D:\DOVEs\Année_2025\Test" & "\"
    fichier = Dir(chemin & "*.xlsx")
    lig = 3
    compte = 0
 
    Set ws = ThisWorkbook
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.DisplayAlerts = False
 
    Rows(lig & ":" & Rows.Count).ClearContents
 
    While fichier <> ""
        compte = compte + 1
        Application.StatusBar = compte & " " & fichier
    
        ' *** CHANGEMENT CLÉ : Ouvrir et fermer le fichier ***
        On Error Resume Next
        Set wb = Workbooks.Open(chemin & fichier, UpdateLinks:=False, ReadOnly:=True, Notify:=False)
    
        If Not wb Is Nothing Then
            trouve = 0
        
            ' Lecture directe au lieu de ExecuteExcel4Macro
            LectureDirecte wb, Feuil1, col1, crit1, lig
            LectureDirecte wb, Feuil1, col1, crit2, lig
            LectureDirecte wb, Feuil1, col1, crit3, lig
            LectureDirecte wb, Feuil2, col1, crit4, lig
        
            If trouve = 1 Then lig = lig + 1
        
            ' FERMER IMMÉDIATEMENT
            wb.Close SaveChanges:=False
            Set wb = Nothing
        End If
        On Error GoTo 0
    
        fichier = Dir
        trouve = 0
    
        ' Nettoyage mémoire plus fréquent
        If (compte Mod 100) = 0 Then
            Application.StatusBar = compte & " fichiers - Nettoyage mémoire..."
            ws.Save ' Sauvegarde intermédiaire
            DoEvents
        End If
    
        ' Nettoyage agressif tous les 500 fichiers
        If (compte Mod 500) = 0 Then
            CollectGarbage
        End If
    Wend
 
    ' Restauration
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    Application.StatusBar = False
 
    MsgBox "Terminé : " & compte & " fichiers en " & Format(Timer - t, "0.00") & " secondes"
End Sub

Sub LectureDirecte(wb As Workbook, nomFeuil$, col%, crit$, lig&)
    Dim ws As Worksheet
    Dim plage As Range, cell As Range
    Dim ligTrouvee As Long
 
    On Error Resume Next
    Set ws = wb.Worksheets(nomFeuil)
    On Error GoTo 0
 
    If ws Is Nothing Then Exit Sub
 
    ' Recherche dans la colonne spécifiée
    Set plage = ws.Range(ws.Cells(1, col), ws.Cells(5000, col))
    Set cell = plage.Find(What:=crit, LookIn:=xlValues, LookAt:=xlWhole)
 
    If Not cell Is Nothing Then
        trouve = 1
        ligTrouvee = cell.Row
    
        Cells(lig, 1) = fichier
    
        Select Case crit
            Case crit1, crit2, crit3
                Cells(lig, IIf(crit = crit1, 2, IIf(crit = crit2, 3, 4))) = ws.Cells(ligTrouvee, col + 1).Value
            Case crit4
                Cells(lig, 5) = ws.Cells(ligTrouvee, col).Value
        End Select
    End If
 
    Set ws = Nothing
    Set plage = Nothing
    Set cell = Nothing
End Sub

Sub CollectGarbage()
    ' Forcer la libération mémoire
    Dim i As Long
    For i = 1 To 3
        DoEvents
        Application.Calculate
    Next i
End Sub

Option Explicit

Sub RechercheADODB()
    Dim t As Double, chemin$, fichier$, compte&
    Dim conn As Object, rs As Object
    Dim wsResult As Worksheet
    Dim lig As Long
    Dim connString$, sql$
    Dim v1, v2, v3, v4
 
    t = Timer
    chemin = "D:\DOVEs\Année_2025\Test\"
 
    Set wsResult = ThisWorkbook.ActiveSheet
    lig = 3
 
    ' RAZ
    wsResult.Rows(lig & ":" & wsResult.Rows.Count).ClearContents
 
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
 
    fichier = Dir(chemin & "*.xlsx")
 
    While fichier <> ""
        compte = compte + 1
        Application.StatusBar = compte & " " & fichier
     
        On Error Resume Next
     
        ' Connexion ADODB
        Set conn = CreateObject("ADODB.Connection")
     
 
            connString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=" & chemin & fichier & ";" & _
                        "Extended Properties=""Excel 12.0 Xml;HDR=NO;IMEX=1;ReadOnly=True"";"
      
     
        conn.Open connString
     
        If Err.Number = 0 Then
            v1 = Empty: v2 = Empty: v3 = Empty: v4 = Empty
         
            ' Recherche dans feuille DOVE
            v1 = ChercherValeur(conn, "DOVE", "Véhicule :", 1, 2)
            v2 = ChercherValeur(conn, "DOVE", "Vin :", 1, 2)
            v3 = ChercherValeur(conn, "DOVE", "Battery Identification Number :", 1, 2)
         
            ' Recherche dans feuille Communication
            v4 = ChercherValeur(conn, "Communication", "<- 62 F0 29*", 1, 1)
         
            ' Écrire si au moins une valeur trouvée
            If Not IsEmpty(v1) Or Not IsEmpty(v2) Or Not IsEmpty(v3) Or Not IsEmpty(v4) Then
                wsResult.Cells(lig, 1) = fichier
                If Not IsEmpty(v1) Then wsResult.Cells(lig, 2) = v1
                If Not IsEmpty(v2) Then wsResult.Cells(lig, 3) = v2
                If Not IsEmpty(v3) Then wsResult.Cells(lig, 4) = v3
                If Not IsEmpty(v4) Then wsResult.Cells(lig, 5) = v4
                lig = lig + 1
            End If
         
            conn.Close
        End If
     
        On Error GoTo 0
        Set conn = Nothing
        Set rs = Nothing
     
        fichier = Dir
     
        ' Sauvegarde intermédiaire
        If (compte Mod 500) = 0 Then
            Application.StatusBar = compte & " fichiers - Sauvegarde..."
            wsResult.Parent.Save
            DoEvents
        End If
    Wend
 
    ' Restauration
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.StatusBar = False
 
    MsgBox "Terminé : " & compte & " fichiers en " & Format(Timer - t, "0.00") & " secondes", vbInformation
End Sub

Function ChercherValeur(conn As Object, nomFeuille$, critere$, colCherche As Integer, colResultat As Integer) As Variant
    Dim rs As Object
    Dim sql$, i As Integer
    Dim valeur As Variant
 
    On Error Resume Next
 
    valeur = Empty
 
    ' Construction SQL - ADODB utilise F1, F2, F3... pour les colonnes
    sql = "SELECT * FROM [" & nomFeuille & "$A1:Z5000] " & _
          "WHERE F" & colCherche & " = '" & Replace(critere, "'", "''") & "'"
 
    Set rs = CreateObject("ADODB.Recordset")
    rs.Open sql, conn, 3, 1 ' adOpenStatic, adLockReadOnly
 
    If Not rs.EOF Then
        ' Récupérer la valeur de la colonne résultat
        valeur = rs.Fields("F" & colResultat).Value
    End If
 
    rs.Close
    Set rs = Nothing
 
    On Error GoTo 0
 
    ChercherValeur = valeur
End Function

Option Explicit

Sub RechercheAvecIndexWindows()
    Dim t As Double, chemin$, compte&
    Dim wsResult As Worksheet
    Dim lig As Long
    Dim collFichiers As Collection
    Dim fichier As Variant
    Dim conn As Object
    Dim connString$
    Dim v1, v2, v3, v4
    
    t = Timer
    chemin = "D:\DOVEs\Année_2025\Test\"
    
    Set wsResult = ThisWorkbook.ActiveSheet
    lig = 3
    
    ' RAZ
    wsResult.Rows(lig & ":" & wsResult.Rows.Count).ClearContents
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.StatusBar = "Recherche via Windows Search Index..."
    
    ' *** PRÉSÉLECTION VIA WINDOWS SEARCH ***
    Set collFichiers = RechercherFichiersIndexes(chemin, Array("Véhicule", "Vin", "Battery", "62 F0 29"))
    
    If collFichiers.Count = 0 Then
        MsgBox "Aucun fichier trouvé via Windows Search Index." & vbCrLf & _
               "Vérifiez que l'indexation est activée pour ce dossier.", vbExclamation
        GoTo Cleanup
    End If
    
    Application.StatusBar = collFichiers.Count & " fichiers présélectionnés - Traitement ADODB..."
    
    ' *** TRAITEMENT ADODB DES FICHIERS PRÉSÉLECTIONNÉS ***
    For Each fichier In collFichiers
        compte = compte + 1
        Application.StatusBar = compte & "/" & collFichiers.Count & " - " & Dir(fichier)
        
        On Error Resume Next
        
        Set conn = CreateObject("ADODB.Connection")
        
        connString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                    "Data Source=" & fichier & ";" & _
                    "Extended Properties=""Excel 12.0 Xml;HDR=NO;IMEX=1;ReadOnly=True"";"
        
        conn.Open connString
        
        If Err.Number = 0 Then
            v1 = Empty: v2 = Empty: v3 = Empty: v4 = Empty
            
            ' Recherche dans feuille DOVE
            v1 = ChercherValeur(conn, "DOVE", "Véhicule :", 1, 2)
            v2 = ChercherValeur(conn, "DOVE", "Vin :", 1, 2)
            v3 = ChercherValeur(conn, "DOVE", "Battery Identification Number :", 1, 2)
            
            ' Recherche dans feuille Communication
            v4 = ChercherValeur(conn, "Communication", "<- 62 F0 29*", 1, 1)
            
            ' Écrire si au moins une valeur trouvée
            If Not IsEmpty(v1) Or Not IsEmpty(v2) Or Not IsEmpty(v3) Or Not IsEmpty(v4) Then
                wsResult.Cells(lig, 1) = Dir(fichier)
                If Not IsEmpty(v1) Then wsResult.Cells(lig, 2) = v1
                If Not IsEmpty(v2) Then wsResult.Cells(lig, 3) = v2
                If Not IsEmpty(v3) Then wsResult.Cells(lig, 4) = v3
                If Not IsEmpty(v4) Then wsResult.Cells(lig, 5) = v4
                lig = lig + 1
            End If
            
            conn.Close
        End If
        
        On Error GoTo 0
        Set conn = Nothing
        
        ' Sauvegarde intermédiaire
        If (compte Mod 500) = 0 Then
            wsResult.Parent.Save
            DoEvents
        End If
    Next fichier
    
Cleanup:
    ' Restauration
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.StatusBar = False
    
    MsgBox "Terminé : " & compte & " fichiers traités en " & Format(Timer - t, "0.00") & " secondes", vbInformation
End Sub

Function RechercherFichiersIndexes(chemin$, motsCles As Variant) As Collection
    Dim conn As Object
    Dim rs As Object
    Dim sql$
    Dim collResultat As New Collection
    Dim whereClauses As String
    Dim i As Integer
    Dim cheminNormalise$
    
    ' Normaliser le chemin pour Windows Search
    cheminNormalise = Replace(chemin, "\", "/")
    If Right(cheminNormalise, 1) = "/" Then
        cheminNormalise = Left(cheminNormalise, Len(cheminNormalise) - 1)
    End If
    
    ' Construction de la clause WHERE avec plusieurs mots-clés (OR)
    whereClauses = ""
    For i = LBound(motsCles) To UBound(motsCles)
        If whereClauses <> "" Then whereClauses = whereClauses & " OR "
        whereClauses = whereClauses & "CONTAINS(*, '""" & motsCles(i) & """')"
    Next i
    
    ' Requête SQL pour Windows Search
    sql = "SELECT System.ItemPathDisplay " & _
          "FROM SystemIndex " & _
          "WHERE SCOPE='file:///" & cheminNormalise & "' " & _
          "AND System.FileExtension = '.xlsx' " & _
          "AND (" & whereClauses & ")"
    
    On Error Resume Next
    
    ' Connexion à Windows Search
    Set conn = CreateObject("ADODB.Connection")
    conn.ConnectionString = "Provider=Search.CollatorDSO;Extended Properties='Application=Windows';"
    conn.Open
    
    If Err.Number <> 0 Then
        MsgBox "Erreur connexion Windows Search : " & Err.Description & vbCrLf & _
               "Vérifiez que l'indexation Windows est activée.", vbCritical
        On Error GoTo 0
        Set RechercherFichiersIndexes = collResultat
        Exit Function
    End If
    
    Set rs = CreateObject("ADODB.Recordset")
    rs.Open sql, conn, 3, 1 ' adOpenStatic, adLockReadOnly
    
    If Err.Number <> 0 Then
        MsgBox "Erreur requête Windows Search : " & Err.Description, vbCritical
        On Error GoTo 0
        conn.Close
        Set RechercherFichiersIndexes = collResultat
        Exit Function
    End If
    
    On Error GoTo 0
    
    ' Récupération des chemins
    While Not rs.EOF
        collResultat.Add rs.Fields("System.ItemPathDisplay").Value
        rs.MoveNext
    Wend
    
    rs.Close
    conn.Close
    
    Set rs = Nothing
    Set conn = Nothing
    Set RechercherFichiersIndexes = collResultat
End Function

Function ChercherValeur(conn As Object, nomFeuille$, critere$, colCherche As Integer, colResultat As Integer) As Variant
    Dim rs As Object
    Dim sql$
    Dim valeur As Variant
    
    On Error Resume Next
    
    valeur = Empty
    
    ' Construction SQL
    If critere Like "*\**" Then ' Si contient wildcard
        sql = "SELECT * FROM [" & nomFeuille & "$A1:Z5000] " & _
              "WHERE F" & colCherche & " LIKE '" & Replace(critere, "*", "%") & "'"
    Else
        sql = "SELECT * FROM [" & nomFeuille & "$A1:Z5000] " & _
              "WHERE F" & colCherche & " = '" & Replace(critere, "'", "''") & "'"
    End If
    
    Set rs = CreateObject("ADODB.Recordset")
    rs.Open sql, conn, 3, 1
    
    If Not rs.EOF Then
        valeur = rs.Fields("F" & colResultat).Value
    End If
    
    rs.Close
    Set rs = Nothing
    
    On Error GoTo 0
    
    ChercherValeur = valeur
End Function

' *** FONCTION UTILITAIRE : Vérifier l'indexation d'un dossier ***
Sub VerifierIndexation()
    Dim chemin$
    chemin = "D:\DOVEs\Année_2025\Test\"
    
    Dim conn As Object, rs As Object, sql$
    Dim compte As Long
    
    sql = "SELECT System.ItemPathDisplay FROM SystemIndex " & _
          "WHERE SCOPE='file:///" & Replace(chemin, "\", "/") & "' " & _
          "AND System.FileExtension = '.xlsx'"
    
    On Error Resume Next
    Set conn = CreateObject("ADODB.Connection")
    conn.ConnectionString = "Provider=Search.CollatorDSO;Extended Properties='Application=Windows';"
    conn.Open
    
    If Err.Number = 0 Then
        Set rs = conn.Execute(sql)
        While Not rs.EOF
            compte = compte + 1
            rs.MoveNext
        Wend
        MsgBox compte & " fichiers Excel indexés dans : " & chemin, vbInformation
        rs.Close
        conn.Close
    Else
        MsgBox "Windows Search non disponible : " & Err.Description, vbCritical
    End If
End Sub