Printing causing Out of Memory

WarPigl3t

WarPigl3t

Well-known Member
Joined
May 25, 2014
Messages
1,611
Hi there. I just finished writing a bunch of macros and it's causing an Out of Memory error each time I run it. I first thought it was my printSetup macro, so I commented it out. It's not my printSetup macro. The error is being caused the second time I send something to be printed. I highlighted the second time I print in red in the code below. Do you have any ideas of how I can accomplish printing all these pages without causing an Out of Memory error? Note that row 3 is dates formatted to show only the day.

[TABLE="class: grid, width: 1200"]
<tbody>[TR]
[TD="align: center"]
[/TD]
[TD="colspan: 2, align: center"]A B
[/TD]
[TD="align: center"]C
[/TD]
[TD="align: center"]D
[/TD]
[TD="align: center"]E
[/TD]
[TD="align: center"]F
[/TD]
[TD="align: center"]G
[/TD]
[TD="align: center"]H
[/TD]
[TD="align: center"]I
[/TD]
[TD="align: center"]J
[/TD]
[TD="align: center"]K
[/TD]
[TD="align: center"]L
[/TD]
[TD="align: center"]M
[/TD]
[TD="align: center"]N
[/TD]
[TD="align: center"]O
[/TD]
[TD="align: center"]P
[/TD]
[TD="align: center"]Q
[/TD]
[/TR]
[TR]
[TD="align: center"]1
[/TD]
[TD="colspan: 2"]Master Schedule[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: center"]2
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]S[/TD]
[TD]S[/TD]
[TD]M[/TD]
[TD]T[/TD]
[TD]W[/TD]
[TD]T[/TD]
[TD]F[/TD]
[TD]S[/TD]
[TD]S[/TD]
[TD]M[/TD]
[/TR]
[TR]
[TD="align: center"]3
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]7[/TD]
[TD]8[/TD]
[TD]9[/TD]
[TD]10[/TD]
[TD]11[/TD]
[TD]12[/TD]
[TD]13[/TD]
[TD]14[/TD]
[TD]15[/TD]
[TD]16[/TD]
[/TR]
[TR]
[TD="align: center"]4
[/TD]
[TD]Phone #[/TD]
[TD]Name[/TD]
[TD]Job Title[/TD]
[TD]Charge Nurse[/TD]
[TD]Status[/TD]
[TD]D / N[/TD]
[TD]Notes[/TD]
[TD]Column1[/TD]
[TD]Column2[/TD]
[TD]Column3[/TD]
[TD]Column4[/TD]
[TD]Column5[/TD]
[TD]Column6[/TD]
[TD]Column7[/TD]
[TD]Column8[/TD]
[TD]Column9
[/TD]
[TD]Column10[/TD]
[/TR]
[TR]
[TD="align: center"]5
[/TD]
[TD](222)222-2222[/TD]
[TD]Name 1[/TD]
[TD]CNA[/TD]
[TD]CN[/TD]
[TD]FT[/TD]
[TD]Day[/TD]
[TD][/TD]
[TD]R[/TD]
[TD]D[/TD]
[TD]N[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: center"]6
[/TD]
[TD](333)333-3333[/TD]
[TD]Name 2[/TD]
[TD]RN[/TD]
[TD]Relieve CN[/TD]
[TD]FT[/TD]
[TD]Day[/TD]
[TD][/TD]
[TD]NA[/TD]
[TD]X[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: center"]7
[/TD]
[TD](111)111-1111[/TD]
[TD]Name 3[/TD]
[TD]RN[/TD]
[TD][/TD]
[TD]PT[/TD]
[TD]Day[/TD]
[TD]test note[/TD]
[TD]L[/TD]
[TD]X[/TD]
[TD]N[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

Code: 
'Constant Variables
'Sheet3(Master)
Const phoneCol_sht3 = 1
Const nameCol_sht3 = 2
Const jobCol_sht3 = 3
Const chargeCol_sht3 = 4
Const StatusCol_sht3 = 5
Const dayNightCol_sht3 = 6
Const notesCol_sht3 = 7
Const dateStartCol_sht3 = 8
Const dateRow_sht3 = 3
Const headerRow = 4
Const datasetStartRow_sht3 = 5

Sub printMaster_mainMacro()
    dateStart = InputBox("Enter the first date of the schedule", "Start Date")
    If dateStart = "" Then End
    dateEnd = InputBox("Enter the last date of the schedule", "End Date")
    If dateEnd = "" Then End
    Cells.Rows.Hidden = False
    Cells.Columns.Hidden = False
    lastRow = Cells(Rows.Count, nameCol_sht3).End(xlUp).Row
    
    Call inputDateErrorHandler(dateStart, dateEnd)
    dateColumns = findColumnsWithDateRange(dateStart, dateEnd)
    dateStartColumn = dateColumns(0)
    dateEndColumn = dateColumns(1)

    Call applySortFields
    Call hideCertainColumns
    Call displayDateRange(dateStartColumn, dateEndColumn)
    'Call printSetup
    
    Columns(chargeCol_sht3).Hidden = False
    Call displaySpecificJobTitles("RN", "CN", "Day", lastRow)
    ActiveSheet.PrintOut Copies:=1 [COLOR=#008000][B]'Here is the first time it prints[/B][/COLOR]
    Columns(chargeCol_sht3).Hidden = True
    
    Call displaySpecificJobTitles("RN", "", "Day", lastRow)
    [COLOR=#ff0000][B]ActiveSheet.PrintOut Copies:=1[/B][/COLOR][COLOR=#008000][B] 'This is where it causes out of memory error.[/B][/COLOR]
    
    
    Call displaySpecificJobTitles("LVN", "", "Day", lastRow)
    ActiveSheet.PrintOut Copies:=1
    
    
    Call displaySpecificJobTitles("CNA", "", "Day", lastRow)
    ActiveSheet.PrintOut Copies:=1
    
    
    Call displaySpecificJobTitles("MT", "", "Day", lastRow)
    ActiveSheet.PrintOut Copies:=1
    
    
    Call displaySpecificJobTitles("UC", "", "Day", lastRow)
    ActiveSheet.PrintOut Copies:=1
    
    
    Columns(chargeCol_sht3).Hidden = False
    Call displaySpecificJobTitles("RN", "CN", "Night", lastRow)
    ActiveSheet.PrintOut Copies:=1
    Columns(chargeCol_sht3).Hidden = True
    
    
    Call displaySpecificJobTitles("RN", "", "Night", lastRow)
    ActiveSheet.PrintOut Copies:=1
    
    Call displaySpecificJobTitles("LVN", "", "Night", lastRow)
    ActiveSheet.PrintOut Copies:=1
    
    Call displaySpecificJobTitles("CNA", "", "Night", lastRow)
    ActiveSheet.PrintOut Copies:=1
    
    Call displaySpecificJobTitles("MT", "", "Night", lastRow)
    ActiveSheet.PrintOut Copies:=1
    
    Call displaySpecificJobTitles("UC", "", "Night", lastRow)
    ActiveSheet.PrintOut Copies:=1

    Cells.Rows.Hidden = False
    Cells.Columns.Hidden = False
End Sub

Sub displaySpecificJobTitles(myJob, myCharge, myDorN, lastRow)
    r = datasetStartRow_sht3
    Do Until r > lastRow
        rJob = Cells(r, jobCol_sht3).Value
        rCharge = Cells(r, chargeCol_sht3).Value
        rDorN = Cells(r, dayNightCol_sht3).Value
        If rJob Like "* / *" Then
            mySplit = Split(rJob, " / ")
            rJob = mySplit(0)
        ElseIf rJob Like "*/*" Then
            mySplit = Split(rJob, "/")
            rJob = mySplit(0)
        End If
        If rDorN Like "* / *" Then
            mySplit = Split(rDorN, " / ")
            rDorN = mySplit(0)
        ElseIf rDorN Like "*/*" Then
            mySplit = Split(rDorN, "/")
            rDorN = mySplit(0)
        End If
        If myCharge = "" Then
            If UCase(Trim(rJob)) = UCase(myJob) _
            And rCharge = myCharge _
            And UCase(Trim(rDorN)) = UCase(myDorN) Then
                Rows(r).Hidden = False
            Else
                Rows(r).Hidden = True
            End If
        Else
            If UCase(Trim(rJob)) = UCase(myJob) _
            And UCase(Trim(rCharge)) Like "*" & UCase(myCharge) & "*" _
            And UCase(Trim(rDorN)) = UCase(myDorN) Then
                Rows(r).Hidden = False
            Else
                Rows(r).Hidden = True
            End If
        End If
        r = r + 1
    Loop
End Sub

Sub printSetup()
    'Columns("B:" & lastColumn).Select
    'Range("Table3[[#Headers],[Name]]").Activate
    'ActiveSheet.PageSetup.PrintArea = "$B:$Q"
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$4"
        .PrintTitleColumns = ""
    End With
    'Application.PrintCommunication = True
    'ActiveSheet.PageSetup.PrintArea = "$A:$Q"
    'Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0)
        .RightMargin = Application.InchesToPoints(0)
        .TopMargin = Application.InchesToPoints(0.75)
        .BottomMargin = Application.InchesToPoints(0)
        .HeaderMargin = Application.InchesToPoints(0)
        .FooterMargin = Application.InchesToPoints(0)
        .PrintHeadings = False
        .PrintGridlines = True
        .PrintComments = xlPrintNoComments
        .PrintQuality = 300
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperLetter
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = False
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = True
    'ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True ',
        'IgnorePrintAreas:=False
        
        'ActiveSheet.PageSetup.PrintArea = ""
End Sub

Sub displayDateRange(dateStartColumn, dateEndColumn)
    c = dateStartCol_sht3
    lastColumn = Cells(dateRow_sht3, Columns.Count).End(xlToLeft).Column
    Do Until c > lastColumn
        If c < dateStartColumn Or c > dateEndColumn Then
            Columns(c).Hidden = True
        End If
        c = c + 1
    Loop
End Sub
Function findColumnsWithDateRange(dateStart, dateEnd)
    c = dateStartCol_sht3
    lastColumn = Cells(dateRow_sht3, Columns.Count).End(xlToLeft).Column
    Do Until c > lastColumn
        cValue = Cells(dateRow_sht3, c).Value
        If cValue = dateStart Then
            cStart = c
            Exit Do
        End If
        c = c + 1
    Loop
    Do Until c > lastColumn
        cValue = Cells(dateRow_sht3, c).Value
        If cValue = dateEnd Then
            cEnd = c
            Exit Do
        End If
        c = c + 1
    Loop
    If Cells(dateRow_sht3, cStart).Value = "" _
    Or Cells(dateRow_sht3, cEnd).Value = "" Then
        msgOutput = "One or both of these dates were not found in the schedule:" _
        & vbNewLine & dateStart & vbNewLine & dateEnd
        MsgBox msgOutput
        End
    End If
    Dim myColumns(1) As Variant
    myColumns(0) = cStart
    myColumns(1) = cEnd
    findColumnsWithDateRange = myColumns()
End Function
Sub hideCertainColumns()
    Columns(phoneCol_sht3).Hidden = True
    Columns(chargeCol_sht3).Hidden = True
    Columns(notesCol_sht3).Hidden = True
End Sub

Sub inputDateErrorHandler(dateStart, dateEnd)
    If Not IsDate(dateStart) Or Not IsDate(dateEnd) Then
        msgOutput = "You entered a value that is not a date." & vbNewLine _
        & "Start Date:  " & dateStart & vbNewLine _
        & "End Date:  " & dateEnd
        MsgBox msgOutput
        End
    End If
    c = dateStartCol_sht3
    lastColumn = Cells(dateRow_sht3, Columns.Count).End(xlToLeft).Column
    firstDate = Cells(dateRow_sht3, c).Value
    lastDate = Cells(dateRow_sht3, lastColumn).Value
    dateStart = CDate(dateStart)
    dateEnd = CDate(dateEnd)
    If dateStart < firstDate Or dateEnd > lastDate Then
        msgOutput = "You entered a date range that exceeds that of the schedule." _
        & vbNewLine & "Start Date:  " & dateStart _
        & vbNewLine & "End Date:  " & dateEnd
        MsgBox msgOutput
        End
    End If
End Sub

Sub applySortFields()
    myWkbk = Sheet3.Name
    myTable = "Table3"
    myDorN = Cells(headerRow, dayNightCol_sht3).Value
    myStatus = Cells(headerRow, StatusCol_sht3).Value
    myCharge = Cells(headerRow, chargeCol_sht3).Value
    myJob = Cells(headerRow, jobCol_sht3).Value
    myName = Cells(headerRow, nameCol_sht3).Value
    
    'Range(myTable & "[#All]").Select
    'Application.AddCustomList ListArray:=Array("FT", "PT", "PRN")
    Sheets(myWkbk).ListObjects(myTable).Sort.SortFields.Clear
    
    Sheets(myWkbk).ListObjects(myTable).Sort.SortFields.Add _
        Key:=Range(myTable & "[" & myDorN & "]"), SortOn:=xlSortOnValues, Order:=xlAscending, _
        DataOption:=xlSortNormal
        
    Sheets(myWkbk).ListObjects(myTable).Sort.SortFields.Add _
        Key:=Range(myTable & "[" & myStatus & "]"), SortOn:=xlSortOnValues, Order:=xlAscending _
        , CustomOrder:="FT,PT,PRN", DataOption:=xlSortNormal
        
    Sheets(myWkbk).ListObjects(myTable).Sort.SortFields.Add _
        Key:=Range(myTable & "[" & myCharge & "]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
        
    Sheets(myWkbk).ListObjects(myTable).Sort.SortFields.Add _
        Key:=Range(myTable & "[" & myJob & "]"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
        
    Sheets(myWkbk).ListObjects(myTable).Sort.SortFields.Add _
        Key:=Range(myTable & "[" & myName & "]"), SortOn:=xlSortOnValues, Order:=xlAscending, _
        DataOption:=xlSortNormal
        
    With Sheets(myWkbk).ListObjects(myTable).Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
 
Last edited:

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.
Sort by date Sort by votes
You must log in or register to reply here.

Similar threads

I
  • Question Question
Advice to remove old code for a new code
Replies
2
Views
247
ipbr21054
I
I
  • Question Question
Listbox not being populate when code is run
Replies
4
Views
692
ipbr21054
I
Guna13
  • Question Question
Help to Optimize Macro Code for Faster Performance
Replies
0
Views
1K
Guna13
Guna13
P
  • Question Question
ListBox Click to textbox & delete row
Replies
0
Views
652
pure vito
P
excelbytes
  • Solved
VBA Code Hanging On One Line When In Personal.XLSB Workbook
Replies
2
Views
452
excelbytes
excelbytes

Forum statistics

Threads
1,226,224
Messages
6,189,728
Members
453,566
Latest member
ariestattle

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top