Bom dia!!

Tente assim.

Sub AleVBA_15467()
   Dim ws As Worksheet, ws1 As Worksheet
   Dim cel          As Range
   Dim LR           As Long
   Dim LR1          As Long
   Dim LC           As Long

   Set ws = Sheets("Folha1")
   Set ws1 = Sheets("Folha2")

   Application.ScreenUpdating = False
   If Not Evaluate("ISREF(Listas!A1)") Then
      Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Listas"
   Else
      Sheets("Listas").Cells.Clear
   End If

   With ws
      LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                       SearchDirection:=xlPrevious).Row
      LC = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
                       SearchDirection:=xlPrevious).Column
      .Sort.SortFields.Clear
      .Sort.SortFields.Add Key:=Range("A2:A" & LR), _
                           SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
      .Sort.SortFields.Add Key:=Range("D2:D" & LR), _
                           SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
      With .Sort
         .SetRange Range(Cells(1, 1), Cells(LR, LC))
         .Header = xlYes
         .MatchCase = False
         .Orientation = xlTopToBottom
         .SortMethod = xlPinYin
         .Apply
      End With

      .Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
                                     CopyToRange:=Sheets("Listas").Range("A1"), Unique:=True
      ActiveWorkbook.Names.Add Name:="Classe", RefersTo:= _
                               "=OFFSET(Listas!$A$2,0,0,(COUNTA(Listas!$A:$A)-1),1)"
      ws1.Cells.ClearContents
      For Each cel In Range("Classe")
         .AutoFilterMode = False
         .Range(.Cells(1, 1), .Cells(LR, LC)).AutoFilter Field:=1, Criteria1:=cel.Value
         With ws1
            On Error Resume Next
            LR1 = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                              SearchDirection:=xlPrevious).Row + 2
            If Err.Number = 91 Then
               LR1 = 1
            End If
            ws.AutoFilter.Range.Copy
            .Cells(LR1, 1).PasteSpecial
         End With
         .ShowAllData
      Next cel
      .AutoFilterMode = False
   End With
   Application.DisplayAlerts = False
   Sheets("Listas").Delete
   Application.DisplayAlerts = True
   Application.ScreenUpdating = True
End Sub

Att