Modify macro code for exporting as pdf

[manekankit]

There is a worksheet called "Index" in column F. Various sheets are listed therein.

I am currently using below code to export listed sheets as pdf. Currently all the sheets are individually exported.

I want all of them to be saved as pdf in a signle pdf file with file name as mentioned in cell F1 of the "Index" Sheet.

Requesting help in modifying below vba code.

Private Sub PDF_Stand()
Sheets("Index").Activate

Application.ScreenUpdating = False
    Dim wb As Workbook
    Dim ruta As String, ruta2 As String, ruta3 As String, ruta4 As String, ruta5 As String, nFile As String, wName As String
    Dim ws As Worksheet, sh As Worksheet, hoja As String
    Dim u As Long, exist As Boolean
   
    Set wb = ActiveWorkbook
    nFile = Format(Date, "dd-mmm-yyyy")
     dt = Format(CStr(Now), "hh_mm")
    ruta = wb.Path & "\"
    ruta2 = ruta & "export"
    If Dir(ruta2, vbDirectory) = Empty Then
        MkDir ruta2
    End If
    ruta3 = ruta2 & "\" & "Pdf"
    If Dir(ruta3, vbDirectory) = Empty Then
        MkDir ruta3
    End If
    ruta4 = ruta3 & "\" & nFile
    If Dir(ruta4, vbDirectory) = Empty Then
        MkDir ruta4
    End If
    ruta5 = ruta4 & "\" & dt
    If Dir(ruta5, vbDirectory) = Empty Then
        MkDir ruta5
    End If
   
    '
    Set ws = Sheets("Index")
    u = ws.Range("F" & Rows.Count).End(xlUp).Row
    For i = 2 To u
        hoja = ws.Cells(i, "F").Value
        exist = False
        wName = hoja & " " & "[" & Format(Date, "dd-mmm-yy") & "]"
        For Each sh In Sheets
            If LCase(sh.Name) = LCase(hoja) Then
                exist = True
                Exit For
            End If
        Next
        If exist Then
            Sheets(hoja).ExportAsFixedFormat Type:=xlTypePDF, _
                Filename:=ruta5 & "\" & "[St] " & wName & " [" & dt & "]" & ".pdf", Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        End If
    Next
    Application.ScreenUpdating = True

   
Dim Resp As VbMsgBoxResult

    Resp = MsgBox("PDFs Created." & vbNewLine & "You should look for the file  at " & ruta5 & vbNewLine & vbNewLine & "Do you want to open the folder?", vbInformation + vbYesNo, "Report ready")

    If Resp = vbYes Then
        ThisWorkbook.FollowHyperlink ruta5
    End If

End Sub

 

[HaHoBe]

Hi manekankit,

how about (untested)

Private Sub MrE_1223472_1614E0B()
' https://www.mrexcel.com/board/threads/modify-macro-code-for-exporting-as-pdf.1223472/

  Dim lngCounter As Long
  Dim lngAnswer As VbMsgBoxResult
  Dim strFolders As String
  Dim strBaseFolder As String
  Dim strFormatDate As String
  Dim strFileDate As String
  Dim strFileName As String
  Dim strFormattedTime As String
  Dim strNames As String
  Dim varArray As Variant
  Dim varFolder As Variant
  Dim wb As Workbook
  Dim wsIndex As Worksheet
  
  Application.ScreenUpdating = False
  Set wb = ActiveWorkbook
  
  strFormatDate = Format(Date, "dd-mmm-yyyy")
  strFormattedTime = Format(Time, "hh_mm")
  strFolders = "export" & "\" & "Pdf" & "\" & strFormatDate & "\" & strFormattedTime
  varFolder = Split(strFolders, "\")
  strBaseFolder = wb.Path & "\"
  For varArray = LBound(varFolder) To UBound(varFolder)
    If Dir(strBaseFolder & varFolder(varArray), vbDirectory) = Empty Then
      MkDir strBaseFolder & varFolder(varArray)
      strBaseFolder = strBaseFolder & varFolder(varArray) & "\"
    End If
  Next varArray
  
  Set wsIndex = wb.Sheets("Index")
  For lngCounter = 2 To wsIndex.Range("F" & Rows.Count).End(xlUp).Row
    strFileName = wsIndex.Cells(lngCounter, "F").Value
    strFileDate = strFileName & " " & "[" & Format(Date, "dd-mmm-yy") & "]"
    If Evaluate("ISREF('" & strFileDate & "'!A1)") Then
      strNames = strNames & strFileDate & ","
    End If
  Next lngCounter
  
  If Len(strNames) > 0 Then
    Worksheets(Split(Left(strNames, Len(strNames) - 1), ",")).Select
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
          Filename:=strBaseFolder & wsIndex.Range("F1").Value & ".pdf", _
          Quality:=xlQualityStandard, _
          IncludeDocProperties:=True, _
          IgnorePrintAreas:=False, _
          OpenAfterPublish:=False
  Else
    MsgBox "Could not find sheets with given date to export", vbInformation, "no work to do"
  End If
  
  Application.ScreenUpdating = True
  Set wsIndex = Nothing
  Set wb = Nothing

  lngAnswer = MsgBox("PDFs Created." & vbNewLine & "You should look for the file  at " & strBaseFolder & _
      vbNewLine & vbNewLine & "Do you want to open the folder?", vbInformation + vbYesNo, "Report ready")

  If lngAnswer = vbYes Then
    ThisWorkbook.FollowHyperlink strBaseFolder
  End If

End Sub

Ciao,
Holger

 

[manekankit]

Hi manekankit,

how about (untested)

Private Sub MrE_1223472_1614E0B()
' https://www.mrexcel.com/board/threads/modify-macro-code-for-exporting-as-pdf.1223472/

  Dim lngCounter As Long
  Dim lngAnswer As VbMsgBoxResult
  Dim strFolders As String
  Dim strBaseFolder As String
  Dim strFormatDate As String
  Dim strFileDate As String
  Dim strFileName As String
  Dim strFormattedTime As String
  Dim strNames As String
  Dim varArray As Variant
  Dim varFolder As Variant
  Dim wb As Workbook
  Dim wsIndex As Worksheet
 
  Application.ScreenUpdating = False
  Set wb = ActiveWorkbook
 
  strFormatDate = Format(Date, "dd-mmm-yyyy")
  strFormattedTime = Format(Time, "hh_mm")
  strFolders = "export" & "\" & "Pdf" & "\" & strFormatDate & "\" & strFormattedTime
  varFolder = Split(strFolders, "\")
  strBaseFolder = wb.Path & "\"
  For varArray = LBound(varFolder) To UBound(varFolder)
    If Dir(strBaseFolder & varFolder(varArray), vbDirectory) = Empty Then
      MkDir strBaseFolder & varFolder(varArray)
      strBaseFolder = strBaseFolder & varFolder(varArray) & "\"
    End If
  Next varArray
 
  Set wsIndex = wb.Sheets("Index")
  For lngCounter = 2 To wsIndex.Range("F" & Rows.Count).End(xlUp).Row
    strFileName = wsIndex.Cells(lngCounter, "F").Value
    strFileDate = strFileName & " " & "[" & Format(Date, "dd-mmm-yy") & "]"
    If Evaluate("ISREF('" & strFileDate & "'!A1)") Then
      strNames = strNames & strFileDate & ","
    End If
  Next lngCounter
 
  If Len(strNames) > 0 Then
    Worksheets(Split(Left(strNames, Len(strNames) - 1), ",")).Select
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
          Filename:=strBaseFolder & wsIndex.Range("F1").Value & ".pdf", _
          Quality:=xlQualityStandard, _
          IncludeDocProperties:=True, _
          IgnorePrintAreas:=False, _
          OpenAfterPublish:=False
  Else
    MsgBox "Could not find sheets with given date to export", vbInformation, "no work to do"
  End If
 
  Application.ScreenUpdating = True
  Set wsIndex = Nothing
  Set wb = Nothing

  lngAnswer = MsgBox("PDFs Created." & vbNewLine & "You should look for the file  at " & strBaseFolder & _
      vbNewLine & vbNewLine & "Do you want to open the folder?", vbInformation + vbYesNo, "Report ready")

  If lngAnswer = vbYes Then
    ThisWorkbook.FollowHyperlink strBaseFolder
  End If

End Sub

Ciao,
Holger

thanks for the revert, getting some error.
it is creating the folder but not exporting the file. it is saying that "Could not find sheets with given date to export"

 

[HaHoBe]

Hi manekankit,

as I may only rely on your code as base for work I would need to know what is the content of the cells in Column F of Sheet Index and if the sheets are really combined with a datestamp. Do you have more than one sheet with the name and different date stamps?

getting some error.

The MessageBox states that no sheets with the date stamp behind the name were found - since I do not know your workbook. I relied on your code

wName = hoja & " " & "[" & Format(Date, "dd-mmm-yy") & "]"

Holger

 

[manekankit]

Hi manekankit,

as I may only rely on your code as base for work I would need to know what is the content of the cells in Column F of Sheet Index and if the sheets are really combined with a datestamp. Do you have more than one sheet with the name and different date stamps?



The MessageBox states that no sheets with the date stamp behind the name were found - since I do not know your workbook. I relied on your code

wName = hoja & " " & "[" & Format(Date, "dd-mmm-yy") & "]"

Holger

My file is having for example 5 sheets

Index, Sheet1, Sheet2, Sheet3 and Sheet4.

I use colum F of 'Index' sheet to define which sheet i want to export as pdf

Eg. If i type Sheet1 in cell F2, and Sheet2 in cell F3, my existing macro will export/save as pdf Sheet2 and Sheet3 in the same path\export\pdf\dd-mmm-yyyy\hh_mm\ {pdf file will be saved here}

Sheets do not have date stamp, but while generating pdf it date/time will be suffixed as per my existing code.

My code is currently running fine, and exporting individual sheet1 and sheet2 as pdf. What i want is it should export both the sheet in a single pdf file.

 

[HaHoBe]

Hi manekankit,

my bad - I got it wrong.

Change

  For lngCounter = 2 To wsIndex.Range("F" & Rows.Count).End(xlUp).Row
    strFileName = wsIndex.Cells(lngCounter, "F").Value
    strFileDate = strFileName & " " & "[" & Format(Date, "dd-mmm-yy") & "]"
    If Evaluate("ISREF('" & strFileDate & "'!A1)") Then
      strNames = strNames & strFileDate & ","
    End If
  Next lngCounter

to

  For lngCounter = 2 To wsIndex.Range("F" & Rows.Count).End(xlUp).Row
    strFileName = wsIndex.Cells(lngCounter, "F").Value
    strFileDate = strFileName & " " & "[" & Format(Date, "dd-mmm-yy") & "]"
    If Evaluate("ISREF('" & strFileName & "'!A1)") Then
      strNames = strNames & strFileName & ","
    End If
  Next lngCounter

Holger

 

[manekankit]

Hi manekankit,

my bad - I got it wrong.

Change

  For lngCounter = 2 To wsIndex.Range("F" & Rows.Count).End(xlUp).Row
    strFileName = wsIndex.Cells(lngCounter, "F").Value
    strFileDate = strFileName & " " & "[" & Format(Date, "dd-mmm-yy") & "]"
    If Evaluate("ISREF('" & strFileDate & "'!A1)") Then
      strNames = strNames & strFileDate & ","
    End If
  Next lngCounter

to

  For lngCounter = 2 To wsIndex.Range("F" & Rows.Count).End(xlUp).Row
    strFileName = wsIndex.Cells(lngCounter, "F").Value
    strFileDate = strFileName & " " & "[" & Format(Date, "dd-mmm-yy") & "]"
    If Evaluate("ISREF('" & strFileName & "'!A1)") Then
      strNames = strNames & strFileName & ","
    End If
  Next lngCounter

Holger

That is working perfectly with the modification you suggested at #6.
Thanks a lot, Holger. You made my day!