Loop through multiple excel worksheets within a workbook using VBA - vba

Here is a piece of code which I have written to do a formatting task on various excel files in a particular folder. However the problem is this only runs on the 1st worksheet of all excel workbooks in that folder. I am not able to loop through all the individual worksheets of all the excel files. Please help me edit the code. Thanks
Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xls"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Change the layout
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = ""
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.7)
.RightMargin = Application.InchesToPoints(0.7)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
'Save and Close Workbook
wb.Close SaveChanges:=True
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub


ou need to loop through all sheets in workbook, added also Dim sht as Worksheet
Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com
Dim wb As Workbook
Dim sht As Worksheet
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xls"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
' added this line, loop through all worksheets in current wb
For Each sht In wb.Worksheets
'Change the layout
Application.PrintCommunication = False
With sht.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = ""
Application.PrintCommunication = False
With sht.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.7)
.RightMargin = Application.InchesToPoints(0.7)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
Next sht
'Save and Close Workbook
wb.Close SaveChanges:=True
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Related

Merging text files in Excel 2013

New at Excel macros so need some help. I have about 60+ text files in a single directory each with just one column of data. I am trying to get/write a macro that will import all the text files but also add a second column that contains the file name.
I have the 2 steps I am trying to do. First Sub gets me the list of file names, the second sub gets my the content of the txt files. So the end result I am looking for is a single sheet with the txt content in column A and the source file's name in column B. I am struggling to get the file name in. The files imports must fallow below each other.
Dim xRow As Long
Dim xDirect$, xFname$, InitialFoldr$
InitialFoldr$ = "C:\Desktop" '<<< Startup folder to begin searching from
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder to list Files from"
.InitialFileName = InitialFoldr$
.Show
If .SelectedItems.Count <> 0 Then
xDirect$ = .SelectedItems(1) & "\"
xFname$ = Dir(xDirect$, 7)
Do While xFname$ <> ""
ActiveCell.Offset(xRow) = Left(xFname$, InStrRev(xFname$, ".") - 1)
xRow = xRow + 1
xFname$ = Dir
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & xFname$, Destination:=Range("$A$1"))
End With
Loop
End If
End With
End Sub
Sub TextContent()
Dim myfiles
Dim i As Integer
myfiles = Application.GetOpenFilename(filefilter:="Text Files (*.txt), *.txt", MultiSelect:=True)
If Not IsEmpty(myfiles) Then
For i = LBound(myfiles) To UBound(myfiles)
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & myfiles(i), Destination:=Range("A" & Rows.Count).End (xlUp).Offset(1, 0))
.Name = "Sample"
.FieldNames = False
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = True
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Next i
Else
MsgBox "No File Selected"
End If
End Sub
Sub FileList()
Dim xRow As Long
Dim xDirect$, xFname$, InitialFoldr$
InitialFoldr$ = "C:\Desktop" '<<< Startup folder to begin searching from
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder to list Files from"
.InitialFileName = InitialFoldr$
.Show
If .SelectedItems.Count <> 0 Then
xDirect$ = .SelectedItems(1) & "\"
xFname$ = Dir(xDirect$, 7)
Do While xFname$ <> ""
ActiveCell.Offset(xRow) = Left(xFname$, InStrRev(xFname$, ".") - 1)
xRow = xRow + 1
xFname$ = Dir
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & xFname$, Destination:=Range("$A$1"))
End With
Loop
End If
End With
End Sub
Sub TextContent()
Dim myfiles
Dim i As Integer
myfiles = Application.GetOpenFilename(filefilter:="Text Files (*.txt), *.txt", MultiSelect:=True)
If Not IsEmpty(myfiles) Then
For i = LBound(myfiles) To UBound(myfiles)
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & myfiles(i), Destination:=Range("A" & Rows.Count).End (xlUp).Offset(1, 0))
.Name = "Sample"
.FieldNames = False
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 437
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = True
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Next i
Else
MsgBox "No File Selected"
End If
End Sub

Something like this should do what you want.
Sub ImportTextFiles()
Dim myFile As String, text As String, textline As String
Dim iRow As Long
Application.ScreenUpdating = False
For iRow = 1 To Range("B" & Rows.Count).End(xlUp).Row
' Reset the text variable
text = ""
' Compose the full path
myFile = Range("A" & iRow).Value & "\" & Range("B" & iRow).Value
' Open the file
Open myFile For Input As #1
' Loop through the lines of the file
Do Until EOF(1)
' Read a line
Line Input #1, textline
' Concatenate text
text = text & " " & textline
Loop
' Close the file
Close #1
' Write text to cell
Range("C" & iRow).Value = Mid(text, 2)
Next iRow
Application.ScreenUpdating = True
End Sub
Feel free to modify the script to suit your specific needs. Keep in mind, you can do pretty much whatever you want to do...

Excel Macro: Import specific CSV-file instead of selecting it

I use the following Macro to import a CSV-file into Excel.
The Macro itself works fine, but when I start the Macro, I always have to select which CSV-file I want to import (a file selection dialog appears).
Is there a way to automatically select C:\test\testfile.csv instead of the file selection dialog?
Thank you!
Sub GetCSVList()
Dim dlgOpen As FileDialog
Set dlgOpen = Application.FileDialog(msoFileDialogFilePicker)
Application.DisplayAlerts = False
On Error Resume Next
Worksheets("Tickets").Delete
On Error GoTo 0
Application.DisplayAlerts = True
With dlgOpen
.AllowMultiSelect = False
''Start in
.InitialFileName = "C:\test"
.Show
End With
For Each fname In dlgOpen.SelectedItems
ImportCSV fname
Next
End Sub
Sub ImportCSV(fname)
Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
ws.Name = "Tickets"
With ws.QueryTables.Add( _
Connection:="TEXT;" & fname, _
Destination:=Range("A1"))
.Name = "Test" & Worksheets.Count + 1
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.TextFilePromptOnRefresh = False
.TextFilePlatform = 65001
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.Refresh BackgroundQuery:=False
'.UseListObject = False
End With
End Sub

Something along the lines of the following where you don't open the dialog picker and instead open by using the filepath?
Sub GetCSVList()
' Dim dlgOpen As FileDialog
' Set dlgOpen = Application.FileDialog(msoFileDialogFilePicker)
Dim filepath As String
filepath = "C:\test\testfile.csv"
Application.DisplayAlerts = False
On Error Resume Next
Worksheets("Tickets").Delete
On Error GoTo 0
Application.DisplayAlerts = True
' With dlgOpen
' .AllowMultiSelect = False
' ''Start in
' .InitialFileName = "C:\test"
' .Show
'End With
'For Each fname In dlgOpen.SelectedItems
ImportCSV filepath
'Next
End Sub

change your GetCSVList sub ....
Sub GetCSVList()
Application.DisplayAlerts = False
On Error Resume Next
Worksheets("Tickets").Delete
On Error GoTo 0
Application.DisplayAlerts = True
ImportCSV "C:\test\testfile.csv"
End Sub

VBA print macro to set page in specific manner

I've been working on a print macro that I think is probably simple. I've tried recording a macro and have been researching for a few hours looking at other peoples code. What I would like is for the macro to:
1) select all cells in the active worksheet
2) set print scale to fit all columns to one page
3) print landscape mode
4) Open print preview (if possible)
5) If #4 is not possible then execute print job.
When I run my current code my excel worksheet gets split into tons of page (checker board style) and then I get an error code. Thanks for reading.
This is my current code:
Sub PrintNOPAsheet()'
' PrintNOPAsheet Macro
Cells.Select
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = "$A$1:$H$346"
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
Application.PrintCommunication = True
Selection.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
End Sub
'

Here's what I usually use, then I made it to match your question. Within the With you can add as many of the properties you have from the recorded macro to suit your code.
Sub printIt()
Dim ws As Worksheet: Set ws = Worksheets("Sheet1")
Dim rng as Range
Dim printRange as String
Set rng = ws.Range("A1:J11")
''''For Dynamic Ranges'''''
With ws
Set rng = .Range(.Range("A1"),.Range("J11").End(xlDown))
End With
''''Range from User Highlighted Cells''''
Set rng = Selection
''''This method is not the best way''''
printRange = ws.Name & "!" & rng.Address
With ws.PageSetup
.PrintArea = printRange
.Zoom = False
.FitToPagesWide = 1 'Question 2
.Orientation = xlLandscape 'Question 3
End With
ws.PrintOut preview:=True 'Question 4
End Sub

Loop through .xml files stored in a folder and format it using VBA

So I have around 100 excel files saved as .xml in my folder and I have written a VBA code which formats the layout settings of each worksheet of all the workbooks(files) in my folder. But the problem is the code does not work on the last worksheet of all the workbooks, it works perfectly fine for the rest i.e. till the last worksheet of each workbook.
Here is the code:
Sub LoopAllExcelFilesInFolder()
Dim wb As Workbook
Dim sht As Worksheet
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xml"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
' added this line, loop through all worksheets in current wb
For Each sht In wb.Worksheets
'Change the layout
Application.PrintCommunication = False
With sht.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = ""
Application.PrintCommunication = False
With sht.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.7)
.RightMargin = Application.InchesToPoints(0.7)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
Next sht
'Save and Close Workbook
wb.Close SaveChanges:=True
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Please let me know where I went wrong.
Thanks

Remove all the lines which say
Application.PrintCommunication = False
Application.PrintCommunication = True

Regularly printing to Adobe PDF from Excel, script to force PDFs to be saved to correct path

I am working on a series of XLS files in Excel. When I am done with them, I need to print them to PDF so that they can be transmitted to a party outside my firm.
I recorded a fairly basic macro to allow me to print these files with the same setting every time. Unfortunately, it is not doing everything I need it to do.
Basically, I want Adobe to ask me where the file should be saved when it's being printed. That is not taking place right now with my script. If I manually print and select the settings "Ask to replace existing PDF file" from the Printer Properties window in Excel, it always asks me where the file should be saved. My script is not catching this, however, and I'm not sure what I need to add.
I have a lot of files to go through (and this is a task that will recur) so the sooner I get this nailed down the better.
Is this something that I can address with my Excel macro, and if so, can anyone point me in the right direction?
Sub PrintToAdobeRedactions()
'
' PrintToAdobeRedactions Macro
' Print redacted worksheets to Adobe with correct settings every time.
'
' Keyboard Shortcut: Ctrl+e
'
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = ""
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = "[Tab]"
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = "Page [Page]"
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.75)
.RightMargin = Application.InchesToPoints(0.75)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(1)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintSheetEnd
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlOverThenDown
.BlackAndWhite = False
.Zoom = 100
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = False
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
Application.PrintCommunication = True
ActiveWorkbook.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
End Sub

To SaveAs a PDF:
Sub SaveAsPDF()
Dim SaveName as String
SaveName = InputBox("Save As File Name?")
ThisWorkbook.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=Application.ActiveWorkbook.Path & Application.PathSeparator & SaveName & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
End Sub