Option Explicit
Sub Moon()
Dim Wb1 As Workbook, Wb2 As Workbook, Ws1 As Worksheet, Ws2 As Worksheet
Dim s$, r&, i&, t%, z&
'déclaration objets du classeur Extraction
Set Wb1 = Workbooks("Extraction.xls"): Set Ws1 = Wb1.Worksheets("Données Etudes")
'classeur Base, ouverture et déclarations des objets
s = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*")
If s = "Faux" Then Exit Sub 'si Annuler, sortir
Set Wb2 = Workbooks.Open(s)
s = Application.InputBox(prompt:="Nom de la feuille concernée ?", Default:=Wb2.Worksheets(1).Name)
If s = "Faux" Then 'si Annuler
Wb2.Close 'fermer base
Exit Sub
End If
Set Ws2 = Wb2.Worksheets(s)
'traitement
r = Ws1.Cells(Rows.Count, 1).End(xlUp).Row 'dernière ligne écrite dans Données Etudes
For i = 2 To Ws2.Cells(Rows.Count, 1).End(xlUp).Row 'pour chaque ligne de la feuille du classeur base
t = 0 'nombre de conditions remplies
'tests conditions
If LCase(Trim(Ws2.Cells(i, 2))) = "hygiène" Then t = t + 1
If LCase(Trim(Ws2.Cells(i, 3))) = "corps" Then t = t + 1
If LCase(Trim(Ws2.Cells(i, 4))) = "bonne" Then t = t + 1
If LCase(Trim(Ws2.Cells(i, 5))) = "dermatologique" Then t = t + 1
If t = 4 Then 'si toutes les conditions sont remplies
r = r + 1 'écriture sera à la ligne suivante
'cas de cellules fusionnées
z = 0
Do Until Ws2.Cells(i - z, 1) <> ""
z = z + 1
Loop
'écriture
Ws1.Cells(r, 1) = Ws2.Cells(i - z, 1)
End If
Next i
Wb2.Close 'fermer base
End Sub