Excel Freezes During Print Macro

[dboatman_z]

Hey, I've tried tons of solutions and browsed the web for more for hours now. Maybe one of you can help.

I have a macro that selects all sheets with a specific string in their name, then prints them. If there are too many sheets, it freezes, and you are unabled to break the macro to debug, and Ctrl+Alt+Del is the only way out. It freezes at different locations each time too...

My original code:

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim x As Integer
    For x = 1 To Worksheets.count
        If VBA.InStr(Worksheets(x).Name, "Lateral Assessment") > 0 Then
            With Worksheets(x).PageSetup
                .Orientation = xlPortrait
                .Zoom = False
                .FitToPagesWide = 1
                .FitToPagesTall = 1
            End With
            Worksheets(x).PrintOut
        End If
    Next x
    Application.ScreenUpdating = True
    Application.EnableEvents = True

I have tried, per other forum threads, the following:

• Adding DoEvents in the loop to allow the system time to process
• Adding a "Wait" timer to give it time to process
• Looping through and setting the pagesetup properties first, then printing (it finishes the loop to set pagesetups fine, but freezes in the print loop like "normal"
• Moved to adding all of the sheets to an array, then sending them as a single print job (it still freezes after 14-16 pages)

I also at one point added a progress bar I use in a lot of my bigger processes, and you can see it progressing through the count before freezing on an inconsistent sheet number. Additionally, note that the problem occurs even if I run it one iteration at a time from the VBA code window, thus, it appears that it is not related to processing time (although one cannot be certain of that).

My current code:

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim x As Long, iTotal As Long, sSheets() As String
    iTotal = -1
    For x = 1 To Worksheets.count
        If VBA.InStr(Worksheets(x).Name, "Lateral Assessment") > 0 Then
            With Worksheets(x).PageSetup
                .Orientation = xlPortrait
                .Zoom = False
                .FitToPagesWide = 1
                .FitToPagesTall = 1
            End With
            iTotal = iTotal + 1
            ReDim Preserve sSheets(iTotal)
            sSheets(iTotal) = Worksheets(x).Name
        End If
    Next x
    If iTotal <> -1 Then
        Sheets(sSheets).PrintOut Copies:=1, Collate:=True
    End If
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True

Any idea why this is happening, and possible solutions that I havent tried?