Hi

Code:
For i = 3 To 38
    strRngName = .Cells(i, 2).Text
    If Not ThisWorkbook.Name = ActiveWorkbook.Name Then ThisWorkbook.Activate
    strShtname = Range(strRngName).Parent.Name
    strFileName = wbkActive.Path & "\" & strShtname & Format(Date, "dd-mm-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