Modify macro code for exporting as pdf

M

manekankit

Board Regular
Joined
Feb 1, 2019
Messages
72
Office Version
  1. 365
Platform
  1. Windows
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.

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
 

Excel Facts

Difference between two dates
Secret function! Use =DATEDIF(A2,B2,"Y")&" years"&=DATEDIF(A2,B2,"YM")&" months"&=DATEDIF(A2,B2,"MD")&" days"
Sort by date Sort by votes
Hi manekankit,

how about (untested)

VBA Code: 
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
 
Upvote 0
HaHoBe said:
Hi manekankit,

how about (untested)

VBA Code: 
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
Click to expand...


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"
 
Upvote 0
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.
Click to expand...

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
VBA Code: 
wName = hoja & " " & "[" & Format(Date, "dd-mmm-yy") & "]"

Holger
 
Upvote 0
HaHoBe said:
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
VBA Code: 
wName = hoja & " " & "[" & Format(Date, "dd-mmm-yy") & "]"

Holger
Click to expand...
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.
 
Upvote 0
Hi manekankit,

my bad - I got it wrong.

Change
VBA Code: 
  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
Rich (BB code): 
  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
 
Upvote 0
Solution
HaHoBe said:
Hi manekankit,

my bad - I got it wrong.

Change
VBA Code: 
  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
Rich (BB code): 
  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
Click to expand...
That is working perfectly with the modification you suggested at #6.
Thanks a lot, Holger. You made my day!
 
Upvote 0
You must log in or register to reply here.

Similar threads

I
  • Question Question
Saved pdf from worksheet doesnt show all the page
Replies
6
Views
252
ipbr21054
I
B
  • Question Question
Using VBA and Acrobat Add-in to export sheet as PDF
Replies
2
Views
287
Basher515
B
C
  • Question Question
Create Folder Using VBA
Replies
8
Views
260
CainyUK
C
V
  • Question Question
Excel VBA - How to modify my code to include a command that prints data to PDF
Replies
1
Views
505
VanGirl
V
D
  • Question Question
Can't get folder to create on desktop. When debugging it shows no errors.
2 3
Replies
24
Views
348
jolivanes
jolivanes

Forum statistics

Threads
1,223,231
Messages
6,170,884
Members
452,364
Latest member
springate

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