Need a macro that will cycle through list then filter, subtotal, and print the list

Hi Crimson Bourne

This code is in the attached. See it it does as you require. Let me know of issues.

Option Explicit
Sub test()
    Dim LR As Long
    Dim Rng As Range
    Dim afRng As Range
    Dim cel As Range
    Dim x As Long

    Application.ScreenUpdating = False
    With Sheet1
        LR = .Range("C" & .Rows.Count).End(xlUp).Row
        Set Rng = .Range("A6:H" & LR)

        For Each cel In Sheets("Dept_List").Range("Dept_No")
            With Rng
                .AutoFilter Field:=3, Criteria1:=cel
            End With

            Set afRng = Sheet1.AutoFilter.Range
            x = Rng.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
            If x >= 1 Then
                Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Temp"
                afRng.Copy
                Sheets("Temp").Range("A6").PasteSpecial Paste:=8
                Sheets("Temp").Range("A6").PasteSpecial Paste:=xlValues
                Sheets("Temp").Range("A6").PasteSpecial Paste:=xlFormats
                Selection.Subtotal GroupBy:=5, Function:=xlSum, TotalList:=Array(8), _
                        Replace:=True, PageBreaks:=False, SummaryBelowData:=True

                With ActiveSheet.PageSetup
                    .Orientation = xlLandscape
                    .FitToPagesWide = 1
                    .FitToPagesTall = 1
                End With

                ' swap these two lines of code to print or to print preview
                '        ActiveSheet.PrintOut
                ActiveSheet.PrintPreview    'for debugging
            Else
            End If
            Sheet1.AutoFilterMode = False
            On Error Resume Next
            Application.DisplayAlerts = False
            Sheets("Temp").Delete
            Application.DisplayAlerts = True
            Sheet1.Activate
            On Error GoTo 0
        Next cel
    End With
    Application.ScreenUpdating = True
End Sub