='C:\dossier\excel\[ClasseurBase.xls]Feuil1'!$A$1

'Faire une RECHERCHE Verticale dans un classeur fermé:
'Rechercher "DVP" dans la colonne A du classeur fermé et 
'afficher la donnée correspondante de la colonne B.
=RECHERCHEV("DVP";'C:\dossier\excel\[ClasseurBase.xls]Feuil1'!$A:$B;2;FAUX)

=INDIRECT("'C:\Documents and Settings\mimi\dossier\excel\["&C2&"]Feuil1'!$A$1")

Function LireCellule_ClasseurFerme( _
        Chemin As String, _
        Fichier As String, _
        Feuille As String, _
        Cellule As Variant) As Variant
    
    Application.Volatile
    
    Dim Source As Object, Rst As Object, ADOCommand As Object
    Dim Cible As String
    
    Feuille = Feuille & "$"
    Cible = Cellule.Address(0, 0, xlA1, 0) & ":" & _
        Cellule.Address(0, 0, xlA1, 0)
      
    Set Source = CreateObject("ADODB.Connection")
    Source.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & Chemin & "\" & Fichier & _
        ";Extended Properties=""Excel 8.0;HDR=No;"";"
                
    Set ADOCommand = CreateObject("ADODB.Command")
    With ADOCommand
        .ActiveConnection = Source
        .CommandText = "SELECT * FROM [" & Feuille & Cible & "]"
    End With
                  
    Set Rst = CreateObject("ADODB.Recordset")
    '1 = adOpenKeyset, 3 = adLockOptimistic
    Rst.Open ADOCommand, , 1, 3
    Set Rst = Source.Execute("[" & Feuille & Cible & "]")
     
    LireCellule_ClasseurFerme = Rst(0).Value
            
    Rst.Close
    Source.Close
    Set Source = Nothing
    Set Rst = Nothing
    Set ADOCommand = Nothing
End Function

Option Explicit
 
Public Function XRECHERCHEV(ByVal valRecherchee As Variant, _
                            ByVal TabMatrice As Variant, _
                            ByVal colonneIndex As Integer)
                            
 
If TypeName(TabMatrice) = "Range" Then
    XRECHERCHEV = Application.WorksheetFunction.VLookup(valRecherchee, _
                                                        TabMatrice, _
                                                        colonneIndex, _
                                                        True)
Else
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim sRange As String
    Dim sSheet As String
    Dim sWbook As String
    Dim sFPath As String
    Dim sSQL   As String
    
    sRange = Replace(Split(TabMatrice, "!")(1), "$", vbNullString)
    sSheet = Split(Split(TabMatrice, "]")(1), "'")(0)
    sWbook = Split(Split(TabMatrice, "[")(1), "]")(0)
    sFPath = Mid(Split(TabMatrice, "[")(0), 2)
        
    valRecherchee = "'" & Replace(valRecherchee, "'", "''") & "'"
    
    sSQL = "SELECT [F" & colonneIndex & "] " & _
           "FROM [" & sSheet & "$" & sRange & "] " & _
           "WHERE [F1] = " & valRecherchee
    
 
    Set db = DAO.OpenDatabase(sFPath & sWbook, False, False, "Excel 8.0;HDR=NO;")
    Set rs = db.OpenRecordset(sSQL, DAO.dbOpenSnapshot)
    
    If rs.EOF And rs.BOF Then
        XRECHERCHEV = "no match"
    Else
        XRECHERCHEV = rs.Fields(0)
    End If
    Set rs = Nothing
    Set db = Nothing
End If
 
End Function

=XRECHERCHEV(A2;"'C:\Perso\[" & D2 & "]_Synthèse'!$A$2:$F$35";6)

Function ConcatVLookUp(ByVal ValRecherche, _
                       ByVal TabMatrice As Range, _
                       ByVal IndexCol, _
              Optional ByVal blnConcat As Boolean = False, _
              Optional ByVal Separateur = ";") As Variant
                  
' Permet une recherchev sur des caractères génériques
'
Dim c As Range
 
application.Volatile
 
For Each c In TabMatrice.Cells
    If c.Value Like ValRecherche Then
        ConcatVLookUp = ConcatVLookUp & Separateur & c.Offset(0, IndexCol - 1).Value
        If Not blnConcat Then Exit For
    End If
Next c
ConcatVLookUp = Mid(ConcatVLookUp, Len(Separateur) + 1)
 
Set c = Nothing
End Function

 
Range("A2:C21").Select
    Selection.Find(What:="170", After:=ActiveCell, LookIn:=xlValues, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False).Activate

Dim objCell As Range, PremAdresse As String, PlageResult As Range
    
    With Range("A2:C21")
        Set objCell = .Find(What:="170", After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext)
        If Not objCell Is Nothing Then
            PremAdresse = objCell.Address
            Do
                If PlageResult Is Nothing Then
                    Set PlageResult = objCell
                Else
                    Set PlageResult = Application.Union(objCell, PlageResult)
                End If
                Set objCell = .FindNext(objCell)
            Loop While Not objCell Is Nothing And objCell.Address <> PremAdresse
        End If
    End With

Private Sub Workbook_Open()
    With Worksheets("Feuil1")
        .Activate
        .Columns(1).Find(Date).Select
    End With
End Sub

 
For Each objCell In ThisWorkbook.Worksheets(1).Cells
    If objCell.Interior.ColorIndex = 5 Then
        If objRange Is Nothing Then
            Set objRange = objCell
        Else
            Set objRange = Application.Union(objCell, objRange)
        End If
    End If
Next

Dim objRange As Range, PlageRed As Range, objCell As Range, PlageResult As Range

'réduction de la plage
For Each objRange In ThisWorkbook.Worksheets(1).Columns
    If IsNull(objRange.Interior.ColorIndex) Then
        If PlageRed Is Nothing Then
            Set PlageRed = objRange
        Else
            Set PlageRed = Application.Union(objRange, PlageRed)
        End If
    End If
Next
'travail en ligne
For Each objRange In ThisWorkbook.Worksheets(1).Rows
    If IsNull(objRange.Interior.ColorIndex) Then
        For Each objCell In Application.Intersect(objRange, PlageRed).Cells
            If objCell.Interior.ColorIndex = 5 Then
                If PlageResult Is Nothing Then
                    Set PlageResult = objCell
                Else
                    Set PlageResult = Application.Union(objCell, PlageResult)
                End If
            End If
        Next
    End If
Next
PlageResult.Select

Dim Repertoire As String, Fichier As String
Dim Wb As Workbook
Dim Ws As Worksheet
Dim i As Integer
 
Application.ScreenUpdating = False
 
'Définit la Première feuille du classeur contenant cette macro
'(pour recevoir les donnée extraites dans les autres classeurs).
Set Ws = ThisWorkbook.Worksheets(1)
 
'Définit le répertoire de recherche
Repertoire = "C:\Documents and Settings\mimi\dossier\"
'Spécifie la recherche pour le fichiers .xls
Fichier = Dir(Repertoire & "*.xls")
 
'Boucle sur les fichiers du répertoire
Do While Fichier <> ""
    'Vérifie que le nom du classeur est différent du classeur
    'contenant cette macro (dans le cas ou il serait placé dans le même répertoire).
    If ThisWorkbook.Name <> Fichier Then
        'Ouvre chaque classeur
        Set Wb = Workbooks.Open(Repertoire & Fichier)
        
        i = i + 1
        'Récupère le contenu de la cellule A1 dans la 1ere feuille de chaque classeur.
        Ws.Cells(i, 1) = Wb.Worksheets(1).Range("A1")
        Ws.Cells(i, 2) = Fichier
        
        'Referme le classeur
        Wb.Close False
    End If
    
    Fichier = Dir
Loop
 
Application.ScreenUpdating = True
MsgBox "Terminé"