TcD

Option Explicit


Sub Ventilation()
    Dim Sh As Worksheet
    Dim Cel As Range
    Dim DerLig As Long
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    For Each Sh In Sheets
        If Sh.Name <> "Data" Then
            Sh.Delete
        End If
    Next Sh
    With Sheets("Data")
        DerLig = .[A65000].End(xlUp).Row
        .Range("A1:R" & DerLig).Name = "Base"
        .[Z1] = .[G1]
        .Range("G1:G" & DerLig).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("Z1"), Unique:=True
        For Each Cel In .Range("Z2:Z" & .[Z65000].End(xlUp).Row)
            If Cel.Value <> "" Then
                .[Z2] = Cel.Value
                Sheets.Add
                ActiveSheet.Name = Cel.Value
                .Range("Base").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("Z1:Z2"), _
                                              CopyToRange:=Range("A1:R1"), Unique:=False
                ActiveSheet.Cells.EntireColumn.AutoFit
            End If
        Next Cel
        .Columns(26).Clear
        .Select
    End With
    Sheets("Data").[A1].Select
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub