Creer des Worksheet pour seulement le filtrage qui n'est pas vide

Bonjour,

SVP ! dans le code suivant, j'essaie de récupérer un fichier de l'utilisateur, le problème que il est pas copié à 100/100, par la suite je filtre sur 2 colonnes pour avoir par exemple un nouveau Worksheet qui contient que la combinaison CTA-FH, par la suite je souhaite créer le nouveau sheet si seulement l'output du filtrage n'est pas vide, ça marche toujours pas, merci d'avance pour toute sorte de proposition.

Sub Selectfile()

Dim WB As Workbook
Dim WB2 As Workbook
Dim WS As Worksheet
Dim SI As Workbook
Dim headerImport As Range
Dim table As ListObject
Dim FileToOpen As Variant
Dim SiFile As Variant
Dim isAccepted As Boolean
Dim cell As Range
isAccepted = True
Dim Regions
Dim Cases
Dim Region As Variant
Dim Cas As Variant
Dim sheet As Worksheet
Dim newWS As Worksheet
Dim rng As Range
Regions = Array("CTA", "IDF", "NOE", "WST", "SWT", "MED")
Cases = Array("FH", "FTTA")

Set WB = ActiveWorkbook

Set WS = WB.Worksheets(1)

FileToOpen = Application.GetOpenFilename(Title:="Please select a file", FileFilter:="Excel Files(*.xls*),*xls*")
SiFile = Application.GetOpenFilename(Title:="Please select a file", FileFilter:="Excel Files(*.xls*),*xls*")
If FileToOpen <> False And SiFile <> False Then
    Set WB2 = Application.Workbooks.Open(FileToOpen)
    Set SI = Application.Workbooks.Open(SiFile)
Else
    Exit Sub
End If

With WB2.Worksheets(1)

'Set headerImport = .Range("A1:N1")
For Each cell In WS.Range("A1:N1")
If cell.Value <> .Range(cell.Address).Value Then isAccepted = False
Next

End With
If isAccepted = False Then

    WB2.Close
    MsgBox ("Retry!")
    Exit Sub
End If
WS.Activate
' clear old data
WS.Range("A2:N" & WS.UsedRange.Rows.Count + 1).EntireRow.Delete
'WS.ListObjects(1).Unlist
WB2.Worksheets(1).Range("A2:N" & WB2.Worksheets(1).UsedRange.Rows.Count).Copy (WB.Worksheets(1).Range("A2"))
WB2.Close
For Each Column In Range("I1:N1").Columns
    Column.ColumnWidth = 15
Next
'Fill in SI numbers
WS.Range("H3").FormulaR1C1 = "=VLOOKUP(RC[-7],'[Num SI.XLSX]Feuil2'!C1:C3,3,FALSE)"
Range("H3").AutoFill Destination:=Range("H3:H" & WS.UsedRange.Rows.Count), Type:=xlFillDefault
SI.Close
'delete worksheet if already exist
For Each sheet In WB.Worksheets
    If sheet.Name <> WS.Name Then
        sheet.Delete
    End If
Next
'Filter basing on regions and case
If WS.AutoFilterMode = True Then
    WS.UsedRange.AutoFilter
End If
For Each Region In Regions
    For Each Cas In Cases
        WS.UsedRange.AutoFilter Field:=4, Criteria1:=Region
        WS.UsedRange.AutoFilter Field:=5, Criteria1:=Cas
        Set rng = WS.AutoFilter.Range
        Set rng = rng.Offset(1).Resize(WS.AutoFilter.Range.Rows.Count - 1)
        If Not IsEmpty(rng.Offset(1)) Then 'here i want to filter sheets that will be created
            Set newWS = WB.Worksheets.Add(After:=WB.Worksheets(WB.Worksheets.Count))
            newWS.Name = Region & Cas
            WS.UsedRange.Cells.Copy
            newWS.Range("A1").Select
            newWS.Paste
            For Each Column In Range("I1:N1").Columns
                Column.ColumnWidth = 15
            Next
        End If
    Next
Next

WS.AutoFilterMode = False