Option Explicit
Sub RechercherDate()
Dim F
Dim Feuille As Byte
Dim C As Range
Dim firstAddress As String
Dim LigneAjout As Long
F = Array("bdd1", "bdd2", "bdd3", "bdd4", "bdd5", "bdd6", "bdd7")
Range("A2:c" & Range("A1").End(xlDown).Row).ClearContents
For Feuille = 0 To UBound(F)
With Worksheets(F(Feuille))
Set C = .Columns(1).Find(Range("e2"), , xlValues, xlPart)
If Not C Is Nothing Then
firstAddress = C.Address
Do
If TimeValue(CDate(C.Offset(0, 1))) >= Range("f2") And TimeValue(CDate(C.Offset(0, 1))) <= Range("g2") Then
LigneAjout = Range("A" & Rows.Count).End(xlUp).Row + 1
C.Resize(, 3).Copy Range("A" & LigneAjout)
'On colle la donnée de la colonne I dans la cellule de la colonne D
C.Offset(0, 8).Copy Range("D" & LigneAjout)
End If
Set C = .Columns(1).FindNext(C)
Loop While Not C Is Nothing And C.Address <> firstAddress
End If
End With
Next Feuille
End Sub
A+