XL 2019 Filtre Avancé avec un tableau comme cristaire vba

Sub test()
Dim ShBa As Worksheet, ShGr As Worksheet
Dim LignA As Long
Dim Arr
Set ShBa = ThisWorkbook.Worksheets("BaseD")
Set ShGr = ThisWorkbook.Worksheets("Resultat")
LignA = ShBa.Cells(ShBa.Rows.Count, 1).End(xlUp).Row
lignb = ShGr.Cells(ShGr.Rows.Count, 1).End(xlUp).Row
Arr = ShBa.Range("A2:I" & LignA)
n = 2
'================================================================
For i = LBound(Arr, 1) To UBound(Arr, 1)
    If Arr(i, 9) <> "Non" Then
            ShBa.Range("M" & n) = ("'" & Arr(i, 4))
            ShBa.Range("N" & n) = "*445"
            n = n + 1
    End If
Next i
'================================================================
ShBa.Range("A1:I" & LignA).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range("M1").CurrentRegion, CopyToRange:=Sheets("Resultat").Range("A1"), Unique:=False
End Sub

For i = LBound(Arr, 1) To UBound(Arr, 1)

    If Arr(i, 9) <> "Non" Then

            Grr(i,1) = ("'" & Arr(i, 4))

            Grr(i,2) = "*445"

            n = n + 1

    End If

Next i
Arr.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Grr, CopyToRange:=Sheets("Resultat").Range("A1"), Unique:=False