Création de feuilles individuelles à partir d'une BDD en fonction d'un filtre

Sub FiltreSemaine()
Dim rng As Range
Dim wsTemp As Worksheet, tabId, tablo
Dim wsNew$
With Sheets("BDD")
    If .Range("A2") = "" Then Exit Sub
    Set rng = .Range("A1:G1" & .Range("A65000").End(xlUp).Row)
    tabId = Application.Transpose(.Range("Identifiants").Value)
End With
Application.ScreenUpdating = False
Set wsTemp = Sheets.Add
With wsTemp
    .Name = "Temp"
    .Range("A1") = "Semaine"
    .Range("A2") = [Semaine]
    .Range("B1") = "Identifiant"
    For i = 1 To UBound(tabId)
        .Range("B2") = tabId(i)
        rng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("A1:B2"), _
                    CopyToRange:=.Range("A5"), Unique:=False
        If .Range("A6") <> "" Then
            tablo = .Range("B6:G6" & .Range("B65000").End(xlUp).Row).Value
            wsNew = tabId(i) & "-Sem" & [Semaine]
            DelFeuille wsNew
            Sheets("Modèle").Copy after:=Sheets(Sheets.Count)
            With ActiveSheet
                .Name = wsNew
                .Range("A5") = [Semaine]
                .Range("B7").Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo
            End With
        End If
        .Range("A5:G65000").Clear
    Next
End With
Application.DisplayAlerts = False
wsTemp.Delete
Application.DisplayAlerts = True
Sheets("BDD").Activate
End Sub

Sub DelFeuille(Feuille As String)
On Error Resume Next
Set ws = Sheets(Feuille)
If Not ws Is Nothing Then
    Application.DisplayAlerts = False
    ws.Delete
    Application.DisplayAlerts = True
End If
On Error GoTo 0
End Sub

Sub FiltreSemaine()
Dim rng As Range, wsNew$
Application.ScreenUpdating = False
With ActiveSheet
    .Range("A1:G1" & .Range("A65000").End(xlUp).Row).Sort Key1:=Range("A2"), _
            Order1:=xlAscending, Key2:=Range("C2"), Order2:=xlAscending, Header:=xlGuess
    .AutoFilterMode = False
    .Range("A1").AutoFilter Field:=1, Criteria1:=[Semaine]
    With .AutoFilter.Range
        On Error Resume Next
        Set rng = .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count) _
            .SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        If Not rng Is Nothing Then
            wsNew = "Semaine" & [Semaine]
            DelFeuille wsNew
            Sheets("Modèle").Copy after:=Sheets(Sheets.Count)
            With ActiveSheet
                .Name = wsNew
                .Range("A5") = [Semaine]
                .Range("B7").Resize(rng.Rows.Count, rng.Columns.Count) = rng.Value
            End With
        End If
    End With
    .AutoFilterMode = False
    .Activate
End With
End Sub

Sub DelFeuille(Feuille As String)
On Error Resume Next
Set ws = Sheets(Feuille)
If Not ws Is Nothing Then
    Application.DisplayAlerts = False
    ws.Delete
    Application.DisplayAlerts = True
End If
On Error GoTo 0
End Sub