Looping accross all worksheets in a workbook

I can only get my code to execute on the first worksheet in the workbook. I've tried to follow several suggestions that I've found online and in books. I'm stumped. It works great one worksheet at a time, but stops after the first worksheet. Can anyone help? I attached the document I'm working with, if that helps....

I have the following:

Sub ProfileFormat6()

Application.ScreenUpdating = False
Dim rng As Range
Dim ws As Worksheet
    
    
    For Each ws In Worksheets
        
            Set rng = Range("A1")
            rng.Activate
            
            Columns("E:E").Select
            ActiveWindow.SelectedSheets.VPageBreaks.Add Before:=ActiveCell
    
                Do While rng.Value <> ""
                    
                    rng.Activate
                    
                    ActiveCell.Offset(1, 0).Range("A1:D1").Select
                        With Selection.Interior
                            .ColorIndex = 15
                            .Pattern = xlSolid
                        End With
                    rng.Activate
                    ActiveCell.Offset(21, 0).Range("A1:D2").Select
                        With Selection.Interior
                            .ColorIndex = 15
                            .Pattern = xlSolid
                        End With
                    rng.Activate
                    ActiveCell.Offset(31, 0).Activate
                    ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
                    
                    rng.Activate
                    Set rng = rng.Offset(31, 0)
                Loop
                
    Next ws

End Sub