Macro qui renvoie les valeurs de plusieurs cellules dans un nouveau tableau

Option Explicit

Sub Moon()
Dim w1 As Worksheet, w2 As Worksheet, i&, r&, t%, z&
Set w1 = Worksheets("BASE"): Set w2 = Worksheets("EXTRACTION")
r = w2.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To w1.Cells(Rows.Count, 1).End(xlUp).Row
    t = 0
    If LCase(Trim(w1.Cells(i, 2))) = "hygiène" Then t = t + 1
    If LCase(Trim(w1.Cells(i, 3))) = "corps" Then t = t + 1
    If LCase(Trim(w1.Cells(i, 4))) = "bonne" Then t = t + 1
    If LCase(Trim(w1.Cells(i, 5))) = "dermatologique" Then t = t + 1
    If t = 4 Then
        r = r + 1
        z = 0
        Do Until w1.Cells(i - z, 1) <> ""
            z = z + 1
        Loop
        w2.Cells(r, 1) = w1.Cells(i - z, 1)
    End If
Next i
End Sub

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

s = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*")