Printing range of sheets in excel or in PDF

I have following macro which prints from the ranges defined, but if i want to print the same ranges and save them in one excel file as sheets separately. And also if i want to print the same and save as pdf file.

Code:

---

Sub Print_Ranges()
    Dim strShtname As String, strRngName As String
    Dim i As Long
       
    With Worksheets("INDEX")
       
        'sort the named range list according to page number order
        .Range("A2").CurrentRegion.Sort key1:=Range("A3"), order1:=xlAscending, Header:=xlYes, ordercustom:=1, Orientation:=xlTopToBottom
   
        'loop through the cells and determine parent of named range and specific range addresses
        For i = 3 To 38
            strRngName = .Cells(i, 2).Text
            strShtname = Range(strRngName).Parent.Name
           
            'clear any existing print areas and reset to named ranges areas
            With Worksheets(strShtname)
                .PageSetup.PrintArea = ""
                .PageSetup.PrintArea = Range(strRngName).Address
                .PrintOut
              '  .PrintPreview
            End With
        Next i
    End With
   
End Sub

---

Kindly assist.

Hi,

Try this. untested.

Code:

---

Sub Print_Ranges()

    Dim strShtname As String, strRngName As String
    Dim i As Long, strFileName  As String
   
       
    With Worksheets("INDEX")
       
        'sort the named range list according to page number order
        .Range("A2").CurrentRegion.Sort key1:=Range("A3"), order1:=xlAscending, Header:=xlYes, ordercustom:=1, Orientation:=xlTopToBottom
   
        'loop through the cells and determine parent of named range and specific range addresses
        For i = 3 To 38
            strRngName = .Cells(i, 2).Text
            strShtname = Range(strRngName).Parent.Name
            strFileName = ThisWorkbook.Path & "\" & strShtname & Format(Date, "mm-dd-yy") & ".pdf"
            'clear any existing print areas and reset to named ranges areas
            With Worksheets(strShtname)
                .PageSetup.PrintArea = ""
                .PageSetup.PrintArea = Range(strRngName).Address
                .PrintOut
              '  .PrintPreview
               
                '// Save the print area as a PDF file
                .ExportAsFixedFormat Type:=xlTypePDF, Filename:=strFileName, _
                    Quality:=xlQualityStandard, IncludeDocProperties:=True, _
                    IgnorePrintAreas:=False, OpenAfterPublish:=False
            End With
        Next i
    End With
   
End Sub

---

Thanks, I will test this..
Can this code be changed to do this saving in excel file. in fact all the ranges are in named sheet and i want to extract them in same named sheet and save them as flat file without formulas (for circulation) and leaving other sheets where named ranges are not taken in 1 to 38.

I would much appreciate that.

Thanks once again.

Hi,

Again untested.

Code:

---

Sub Print_Ranges()

    Dim strShtname As String, strRngName As String
    Dim i As Long, strFileName  As String
    Dim wbkActive  As Workbook
    Dim wbkPDF      As Workbook
    Dim wbkNew      As Workbook
    Dim rngDest    As Range
    Dim RowsCount  As Long
   
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
   
    Set wbkActive = ThisWorkbook
    Set wbkPDF = Workbooks.Add
    Set rngDest = wbkPDF.Worksheets(1).Range("a1")
   
    With wbkActive.Worksheets("INDEX")
       
        'sort the named range list according to page number order
        .Range("A2").CurrentRegion.Sort key1:=Range("A3"), order1:=xlAscending, Header:=xlYes, ordercustom:=1, Orientation:=xlTopToBottom
   
        'loop through the cells and determine parent of named range and specific range addresses
        For i = 3 To 38
            strRngName = .Cells(i, 2).Text
            strShtname = Range(strRngName).Parent.Name
           
            strFileName = wbkActive.Path & "\" & strShtname & Format(Date, "mm-dd-yy")
            'clear any existing print areas and reset to named ranges areas
            With wbkActive.Worksheets(strShtname)
                .PageSetup.PrintArea = ""
                .PageSetup.PrintArea = Range(strRngName).Address
             
                '// Paste the data to the workbook for PDF
                .Range(strRngName).Copy rngDest
                RowsCount = .Range(strRngName).Rows.Count
                Set rngDest = rngDest.Offset(RowsCount)
                '// Paste the data to a new workbook
                Set wbkNew = Workbooks.Add
                .Range(strRngName).Copy wbkNew.Worksheets(1).Range("a1")
                '// Save the print area as a new file
                wbkNew.SaveAs strFileName, 51
                wbkNew.Close
                Set wbkNew = Nothing
            End With
        Next i
    End With
   
    wbkPDF.Worksheets(1).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
                    wbkActive.Path & "\" & Format(Date, "mmmmyy") & ".pdf", _
                    Quality:=xlQualityStandard, IncludeDocProperties:=True, _
                    IgnorePrintAreas:=False, OpenAfterPublish:=False
   
   
   
End Sub

---

Hi
Sorry for getting back very late on this...however, i am getting run time error "1004" on this line

.Range("A2").CurrentRegion.Sort key1:=Range("A3"), order1:=xlAscending, Header:=xlYes, ordercustom:=1, Orientation:=xlTopToBottom

Kindly advise.

Try

Code:

---

.Range("A2").CurrentRegion.Sort key1:=.Range("A3"), order1:=xlAscending, Header:=xlYes, ordercustom:=1, Orientation:=xlTopToBottom

---

Hi, Thank you, however, it loops back to this

Code:

---

strShtname = .Range(strRngName).Parent.Name

---

and stops there. But it does copy first page in the range and opens new wb and paste it there, but copies with formulas and not with correct page setup.

Please assist.

Can you please attach the workbook ?

Hi, Thanks, the file i have after cutting it short, is 1.4 mb, how do i attach it here as it allows only 102kb.

Preserve the format and delete the data before uploading. Also delete unnecessary worksheets.