Let's try this one.
Sub PagesByDescription()
Dim rRange As Range, rCell As Range
Dim wSheet As Worksheet
Dim wSheetStart As Worksheet
Dim strText As String

    Set wSheetStart = ActiveSheet
    wSheetStart.AutoFilterMode = False
    'Set a range variable to the correct item column
    Set rRange = Range("G1", Range("G65536").End(xlUp))
    
        'Delete any sheet called "UniqueList"
        'Turn off run time errors & delete alert
        On Error Resume Next
        Application.DisplayAlerts = False
        Worksheets("UniqueList").Delete
        
        'Add a sheet called "UniqueList"
        Worksheets.Add().Name = "UniqueList"
        
           'Filter the Set range so only a unique list is created
            With Worksheets("UniqueList")
                rRange.AdvancedFilter xlFilterCopy, , _
                 Worksheets("UniqueList").Range("A1"), True
                 
                 'Set a range variable to the unique list, less the heading.
                 Set rRange = .Range("A2", .Range("A65536").End(xlUp))
            End With
            
            On Error Resume Next
            With wSheetStart
                For Each rCell In rRange
                  strText = rCell
                 .Range("A1").AutoFilter 7, strText
                    Worksheets(strText).Delete
                    'Add a sheet named as content of rCell
                    Worksheets.Add().Name = strText
                    'Copy the visible filtered range _
                    (default of Copy Method) and leave hidden rows
                    .UsedRange.Copy Destination:=ActiveSheet.Range("A1")
                    ActiveSheet.Cells.Columns.AutoFit
                Next rCell
            End With
            
        With wSheetStart
            .AutoFilterMode = False
            .Activate
        End With
        
        On Error GoTo 0
        Application.DisplayAlerts = True
End Sub