Option Explicit
Sub Moon2()
Dim Wb1 As Workbook, Wb2 As Workbook, Ws1 As Worksheet, Ws2 As Worksheet
Dim s$, r&, i&, t%, z&, c1%, c2%
c1 = 1 'n° de la colonne à remplir dans Extraction
c2 = 1 'n° de la colonne 'code étude' dans Base
'déclaration objets du classeur Extraction
Set Wb1 = Workbooks("Extraction.xls"): Set Ws1 = Wb1.Worksheets("Données Etudes")
'classeur Base,déclarations des objets
Set Wb2 = Workbooks("Base.xls"): Set Ws2 = Wb2.Worksheets("2008")
'traitement
r = Ws1.Cells(Rows.Count, c1).End(xlUp).Row 'dernière ligne écrite dans Données Etudes
For i = 2 To Ws2.Cells(Rows.Count, c2).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, c2 + 1))) = "hygiène" Then t = t + 1
If LCase(Trim(Ws2.Cells(i, c2 + 2))) = "cheveux" Then t = t + 1
If LCase(Trim(Ws2.Cells(i, c2 + 3))) = "moyenne" Then t = t + 1
If LCase(Trim(Ws2.Cells(i, c2 + 4))) = "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, c2) <> ""
z = z + 1
Loop
'écriture
Ws1.Cells(r, c1) = Ws2.Cells(i - z, c2)
End If
Next i
End Sub