Only save populated spreadsheets with filled in cells as PDF - excel

I'm currently trying to modify a Visual Basic macro to only save spreadsheets in a workbook that have had populated cells.
The current macro just saves the entire 16 sheet workbook as a PDF yet a maximum of 9 of these sheets are sometimes left uncompleted, yet are still saved.
I would like the macro to automatically check if these sheets have been populated, once the 'SAVE' button is clicked and then proceed to only save the filled out (complete) sheets as a PDF.
I would massively appricate any help!
The code below is how the macro currently works when just saving the entire workbook. (There is an IF statement check before it is saved to PDF.)
Sub SaveAsPDF()
With ThisWorkbook.Sheets("COVERPage1PRINT")
If (Len(.Range("C24")) = 0) Then
MsgBox "Ensure Serial Number or Stamp number are filled."
Exit Sub
ElseIf (Len(.Range("H17")) = 0) Then
MsgBox "Ensure Serial Number or Stamp Number are filled."
Exit Sub
Else
ChDir _
"P:\Cells\Spool & Sleeves Cell\Flow Plot Records\EFA\Saved EFA PDF Archive"
fname = Sheets("COVERPage1PRINT").Range("H17")
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"P:\Cells\Spool & Sleeves Cell\Flow Plot Records\EFA\Saved EFA PDF Archive\" & fname, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=True
End If
End With
End Sub

This should do the job
(edited code)
Sub test1()
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim test() As String
Dim i As Integer
Dim pdfpath As String
Dim sheets_to_be_checked() As Variant
Dim a As Boolean
pdfpath = ActiveWorkbook.Path 'YOU CAN ADD YOUR PDF SAVING LOCATION e.g. "C\Users\ABC\Desktop"
i = 0
sheets_to_be_checked = Array("Sheet1", "Sheet3")
Set wbBook = ActiveWorkbook
With ThisWorkbook.Sheets("COVERPage1PRINT")
If (Len(.Range("C24")) = 0) Then
MsgBox "Ensure Serial Number & Tag Number or Stamp number are filled."
Exit Sub
ElseIf (Len(.Range("H16")) = 0) Then
MsgBox "Ensure Serial Number & Tag Number or Stamp Number are filled."
Exit Sub
ElseIf (Len(.Range("H19")) = 0) Then
MsgBox "Ensure Serial Number & Tag Number or Stamp Number are filled."
Exit Sub
Else:
For Each wsSheet In wbBook.Worksheets
With wsSheet
If IsInArray(wsSheet.Name, sheets_to_be_checked) Then
wsSheet.Activate
If WorksheetFunction.CountA(Range("D4:D9, E10:E15, F4:F9, G10:G15, H4:H9, I10:I15, J4:J9, K10:K15")) = 48 Then
ReDim Preserve test(i)
test(i) = wsSheet.Name
i = i + 1
End If
Else:
ReDim Preserve test(i)
test(i) = wsSheet.Name
i = i + 1
End If
End With
Next wsSheet
End If
End With
ThisWorkbook.Sheets(test()).Select
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=pdfpath & "\ouput.pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
End Sub
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function
The answer might change a little depending on your definition of populated sheets. You would have to alter the condition "If .UsedRange.Address <> "$A$1" Then "
One possible alternative to above is WorksheetFunction.CountA(Range("A1:Z100")) <> 0
Please let me know if you need any assistance with the condition or the code.

This is going to depend somewhat on what exactly you mean by 'automatically check if these sheets have been populated'. My crystal ball says that each worksheet has a header row and would be considered 'populated' if there was any data below the first row. In that case, you could cycle through all worksheets and construct an array of worksheet names to be selected. Once multiple worksheets are selected, the PDF creation would be on ActiveSheet.ExportAsFixedFormat not ActiveWorkbook.ExportAsFixedFormat and only those worksheets selected would be included in the PDF.
Dim w As Long, sWSs As String, vWSs As Variant
For w = 1 To Sheets.count
With Sheets(w)
If .Cells(1, 1).CurrentRegion.Rows.count > 1 Then _
sWSs = sWSs & .Name & Chr(215)
End With
Next w
If CBool(Len(sWSs)) Then
vWSs = Split(Left(sWSs, Len(sWSs) - 1), Chr(215))
Sheets(vWSs).Select
ChDir _
"P:\Cells\Spool & Sleeves Cell\Flow Plot Records\EFA\Saved EFA PDF Archive"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"P:\Cells\Spool & Sleeves Cell\Flow Plot Records\EFA\Saved EFA PDF Archive\" & fname, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
Else
MsgBox "Nothing to publish to PDF."
End If
I've tested this with my own sample workbook then tried to incorporate your code sample specifics into my method. If it doesn't work the first time post back a comment and I may be able to offer assistance.

Related

How to insert multiple values in a single excel cell and export it as a pdf for every entry of that cell

i want to insert multiple values in a single cell and export every single entry as a separate pdf. The only thing i did till know is to manually reference the cells and export them as pdfs. This is my macro:
Sub SavePDF()
Range("A8").Value = Range("A8").Value + 1
Sheet3.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:="C:\Users\Report_" & _
ActiveSheet.Range("A8").Value & ".pdf", _
OpenAfterPublish:=False
End Sub
Lets say that i have a range: M6:M14 and i want to input the results in the cell "M1". After i start the macro i want ot create for every single value (the value should be inside the pdf) a new pdf. Example: for the value of M6 a pdf, for M7 another and so on till i reach M14.
Please try this code.
Sub SavePDF()
Dim NameRange As Range
Dim i As Integer
Dim PdfName As String
Set NameRange = Range("M6:M14")
For i = 1 To NameRange.Cells.Count
PdfName = Trim(Range("A8").Value) & i
With Sheet3
.Range("M1").Value = NameRange.Cells(i).Value
.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:="C:\Users\Report_" & PdfName & ".pdf", _
OpenAfterPublish:=False
End With
Next i
End Sub

VBA exits before end

EDIT
I got it to run thru about 1,000 part numbers, but now it stops and excel freezes. Is it possibly too much for excel to handle? Would it be better to add a filter and have user perform this task based off criteria xyz?
I'm using the following code to create a mass form replacement. It's intended to run through a list of 5000+ part numbers, paste the part number into a designated range on another worksheet where it creates the form and saves it as a pdf in a specified folder. It works up until row 105 and then stops. It does what it's supposed to, other than continue down the sheet. I have the same code (modified slightly) being used on another sheet and it runs perfect. I'm not sure why its stopping after a certain number of rows
Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "yyyymmdd\_hhmm")
Dim x As Worksheet
Dim y As Worksheet
Dim i As Long
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 3 To FinalRow
Set x = ThisWorkbook.Worksheets("Part Number Database")
Set y = ThisWorkbook.Worksheets("BOM")
x.Cells(i, 1).Copy Destination:=y.Range("E3:J3")
strFile = Range("E3") & ".pdf"
strPathFile = strPath & strFile
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\Users\AGoodwin\Desktop\BOM\" & strFile & ".pdf" _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
Next i
MsgBox "PDF file has been created: " _
& vbCrLf _
& myFile
End Sub

VBA to select each slicer item AND then save each selected slicer item as a pdf?

I've designed a dashboard consisting of a number of different pivot tables and pivot charts.
All of these pivot tables/charts are controlled by 1 slicer called "Slicer_Store".
There are about 800 different Stores to choose from in this slicer.
I need to save a pdf of EVERY store's dashboard. The process of manually selecting each slicer item, then saving the sheet as a pdf file, is extremely time consuming with 800+ stores, so I was hoping to automate the process via VBA.
Here's my code so far:
Public Sub myMacro()
Dim sI As SlicerItem, sI2 As SlicerItem, sC As SlicerCache
Set sC = ActiveWorkbook.SlicerCaches("Slicer_Store")
With sC
For Each sI In sC.SlicerItems
sC.ClearManualFilter
For Each sI2 In sC.SlicerItems
If sI.Name = sI2.Name Then sI2.Selected = True Else: sI2.Selected = False
Next
Debug.Print sI.Name
'add export to PDF code here
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\Users\TestUser\Desktop\testfolder" & Range("b1").Text & ".pdf", Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Next
End With
End Sub
The code does process all though slicer items, but the file is not being saved as a pdf. I need each file to be saved as the value in B2, so it would be Store1.pdf, Store2.pdf, Store3.pdf, etc.
Any help would be hugely appreciated. This is a big project at work and a lot of people are dependent on these pdf files..
Edited code:
This should work, but it takes forever to go over all of the slicer items (800+). Also, I need to make sure that it only prints the first page (print area) so the slicer itself won't be printed.
Public Sub myMacro()
Dim sI As SlicerItem, sI2 As SlicerItem, sC As SlicerCache
Dim ws As Worksheet
Set sC = ActiveWorkbook.SlicerCaches("Slicer_Store_Number")
Set ws = Sheet18
With sC
For Each sI In sC.SlicerItems
sC.ClearManualFilter
For Each sI2 In sC.SlicerItems
If sI.Name = sI2.Name Then sI2.Selected = True Else: sI2.Selected = False
Next
Debug.Print sI.Name
'add export to PDF code here
ws.PageSetup.PrintArea = ws.Range("A1:N34").Address
ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\Users\testuser\Desktop\testfolder" & Range("M1").Text & ".pdf", Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Next
End With
End Sub
This actually resolve the issue but the approach you get towards 800+ item would take forever to be completed. See below for another solution which needs a little bit of collaboration from the user but it is much faster.
Add this line before printing to PDF:
Range("b1") = sI.Name
This will write name of the store to the range so later you can use it as the name of your pdf file.
Also, add a slash to the end of your path:
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\Users\TestUser\Desktop\testfolder\" & Range("b1").Text & ".pdf", Quality:= _
IF you want to only print first page, you can set the print area right before above lines or use this:
ActiveSheet.PrintOut from:=1, To:=1
UPDATE
In this solution you need to make sure that first slicer item, and only that one is selected (So you should not clear manual filter). This is coded based on that. The original code goes over all of the slicer items each time, select one and deselect the others which causes an extremely high computational cost.
Public Sub myMacro()
Dim sC As SlicerCache
Set sC = ActiveWorkbook.SlicerCaches("Slicer_Store_Number")
'This reminds the user to only select the first slicer item
If sC.VisibleSlicerItems.Count <> 1 Or sC.SlicerItems(1).Selected = False Then
MsgBox "Please Only Select Store-Number 1"
Exit Sub
End If
For i = 1 To sC.SlicerItems.Count
'Do not clear ilter as it causes to select all of the items (sC.ClearManualFilter)
sC.SlicerItems(i).Selected = True
If i <> 1 Then sC.SlicerItems(i - 1).Selected = False
'Debug.Print sI.Name
'add export to PDF code here
With Sheet18.PageSetup
.PrintArea = Sheet18.Range("A1:N34" & lastRow).Address
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
Sheet18.Range("M1") = sC.SlicerItems(i).Name
'This prints to C directory, change the path as you wish
Sheet18.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\" & Range("M1").Text & ".pdf", Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Next
End Sub
Sub FacultyToPDF()
Dim wb As String
Dim sh As Worksheet
Dim fname As String
Dim location As String
Dim sI As SlicerItem, sI2 As SlicerItem, sC As SlicerCache
Dim index As Integer
Const PrintRange = "Print_Area"
fPath = "C:\Users\xiaz01\Desktop\Special Project\PDF"
Set sC = ActiveWorkbook.SlicerCaches("Slicer_billing_phys_name")
For Each sI In ActiveWorkbook.SlicerCaches("Slicer_billing_phys_name").SlicerCacheLevels(1).SlicerItems
ActiveWorkbook.SlicerCaches("Slicer_billing_phys_name").VisibleSlicerItemsList = Array(sI.Name)
fname = Range("B1").Text & Format(Date, " yy-mm-dd") & ".pdf"
Range(PrintRange).ExportAsFixedFormat Type:=xlTypePDF, Filename:=fPath & "\" & fname
Next
End Sub

VBA to Create a folder based on the save path located in a cell

I have the file save path located in J2, so I want to have a macro that creates a folder in the location that's in J2 and if that file is already created to end the process and loop to my other code which creates PDF's and save each one into that location. I already have that code working. I will paste both below:
This is the first code that I'm working on to create a folder based on the location in the cell
Sub MakeMyFolder()
Dim FldrName As String
On Error Resume Next
Set fsoFSO = CreateObject("Scripting.FileSystemObject")
If fsoFSO.FolderExists = Range("J2") Then
MsgBox "found it"
Else
fsoFSO.CreateFolder = Range("J2")
MsgBox "Done"
End If
End Sub
This is my second code that's already working that creates and saves PDF's in the location in J2
Sub PDF_Generator()
Dim cell As Range
Dim wsSummary As Worksheet
Dim counter As Long
Set wsSummary = Sheets("SUMMARY BY PROVIDER")
For Each cell In Worksheets("NAME KEY").Range("$H2:$H60")
If cell.Value <> "Exclude" Then
'progress in status bar
counter = counter + 1
Application.StatusBar = "Processing file: " & counter & "/1042"
With wsSummary
.Range("$B$8").Value = cell.Value
.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=ThisWorkbook.Sheets("SUMMARY BY PROVIDER").Range("J2").Value & _
"\" & cell.Value & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End With
End If
Next cell
Set wsSummary = Nothing
End Sub
I want to get the first code working than combine that procedure with the next, any insight on this question will be great!
These are functions so they have a return value. Try it like this:
fsoFSO.FolderExists(Range("J2"))
instead of
fsoFSO.FolderExists = Range("J2")
The same for CreateFolder:
Sub MakeMyFolder(strFolder as string)
Set fsoFSO = CreateObject("Scripting.FileSystemObject")
If fsoFSO.FolderExists(strFolder) Then
MsgBox "found it"
Else
fsoFSO.CreateFolder(strFolder)
MsgBox "Done"
End If
End Sub
To combine them, add an argument to your sub MakeMyFolder(strFolder as string)
I am assuming your cell that could have exclude will have the folder path, so call your sub with that as the argument; MakeMyFolder cell.Value from in your PDF_generate sub.
Sub MakeMyFolder(strFolder as string)
Set fsoFSO = CreateObject("Scripting.FileSystemObject")
If fsoFSO.FolderExists(strFolder) Then
MsgBox "found it"
Else
fsoFSO.CreateFolder(strFolder)
MsgBox "Done"
End If
End Sub
Sub PDF_Generator()
Dim cell As Range
Dim wsSummary As Worksheet
Dim counter As Long
Set wsSummary = Sheets("SUMMARY BY PROVIDER")
For Each cell In Worksheets("NAME KEY").Range("$H2:$H60")
If cell.Value <> "Exclude" Then
'******* Call your sub here with the folder to be creted ****************************
MakeMyFolder cell.Value
'progress in status bar
counter = counter + 1
Application.StatusBar = "Processing file: " & counter & "/1042"
With wsSummary
.Range("$B$8").Value = cell.Value
.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=ThisWorkbook.Sheets("SUMMARY BY PROVIDER").Range("J2").Value & _
"\" & cell.Value & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End With
End If
Next cell
Set wsSummary = Nothing
End Sub

Filter and Save to pdf in VBA

I'd like to move through a filter and print out what appears on the filtered page to a pdf file before moving onto the next filter item. The idea driving this is that I need to report school building info for each district in my state. I currently have the data sitting in a table (could easily be a pivot with a slicer if that code works out better) with filters set up as I need. The length of columns will change as the district changes to account for varying sizes. Currently, my code does not work. I need help figuring out why.
Sub ShiftandPrint()
Dim i As Integer
i = 1
For cl = 1 To Columns.Count
n = WorksheetFunction.CountA(Columns(cl))
Next
Do While Cells(3, i).Value <> ""
With Sheet1
.AutoFilterMode = False
.Range("n").AutoFilter
.Range("n").AutoFilter Field:=1, Criteria1:=Cell(3, i)
End With
Dim fName As String
With ActiveSheet
fName = .Range("A1").Value & .Range("A2").Value
.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\My Documents\" & fName, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
i = i + 1
Loop
End Sub
Thanks for any help!

Resources