Print selected worksheets in multiple workbooks?

[T & I Forms]

We would like to print two specific worksheets that exist in multiple
workbooks at the same time. In other words, we would like to be able to
select all workbook files in a directory and send to the printer to have the
same two pages from each workbook print, not the entire workbook. We would
like to avoid having to select each file individually to send two sheets to
the printer, and then close and go on to the next file. Is this possible, and
if so, how do we accomplish this? Thanks for any direction you can provide.

 

[JLatham]

I wasn't sure what all you needed, so the code below will do this for you:
Prompt you to select the folder with the .xls* files to be used
... that will pick up .xls, .xlsm, .xlsx, .xlsb, etc type files
It then sorts the list it finds from earliest modified date to latest
After sorting, it begins opening the files one by one and sending the two
sheets you identify to the printer. And goes on to the next file.

As it prepares to open and print from each file, that file's path and
filedate will be put onto the active sheet in your workbook. If there is a
problem in printing the sheets, you'll get an added message in column C for
that file.

You'll need to change the two Const values to hold the names of the 2 sheets
you want printed after you paste it into a workbook. If this all gives you
some big headache, you can get in touch with me via (remove spaces)
HelpFrom @ JLatham Site. com

To put the code to work:
Open Excel and create a new workbook. Press [Alt]+[F11] to open the VB
Editor and choose Insert --> Module and then copy and paste the code below
into it and modify those 2 Const values at the top of it as required. Watch
to see if you end up with two "Option Explicit" statements at the top of the
module and if you do, then delete one of them. Only one Option Explicit
statement is permitted in a module.

Save your workbook with an appropriate name and use Tools-->Macro-->Macros
(Pre Excel 2007) or run the macro from the [Developer] tab in Excel 2007.

Option Explicit
'the sheet names to be printed
'change as required
Const s1Name = "Sheet1"
Const s2Name = "Sheet2"

Dim FilesList() As String
Dim FilesDates() As Date

Sub PrintSheetPairs()
Dim basicPath As String
Dim anyFileName As String
Dim FLLC As Long
Dim hadErrors As Boolean

'select the folder with the files
'to be worked with in it
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count > 0 Then
basicPath = .SelectedItems(1) & "\"
Else
Exit Sub ' user cancelled
End If
End With
ActiveSheet.Cells.Clear
ReDim FilesList(1 To 1)
ReDim FilesDates(1 To 1)
Application.ScreenUpdating = False ' improves speed
'extract Excel files only
anyFileName = Dir$(basicPath & "*.xls*", vbNormal)
Do While anyFileName <> ""
'save the filename
FilesList(UBound(FilesList)) = _
basicPath & anyFileName
'save the file date
FilesDates(UBound(FilesDates)) = _
FileDateTime(basicPath & anyFileName)
anyFileName = Dir$() ' get next filename
ReDim Preserve FilesList(1 To UBound(FilesList) + 1)
ReDim Preserve FilesDates(1 To UBound(FilesDates) + 1)
Loop
If UBound(FilesList) > 1 Then
ReDim Preserve FilesList(1 To UBound(FilesList) - 1)
ReDim Preserve FilesDates(1 To UBound(FilesDates) - 1)
End If
'sort in ascending order by filedate
QuickSortNumbers _
FilesDates, LBound(FilesDates), UBound(FilesDates)
'
'now we begin the real work
'
Application.ScreenUpdating = False
For FLLC = LBound(FilesList) To UBound(FilesList)
'report filename and date of the file
'that we are about to print
Range("A" & FLLC) = FilesList(FLLC)
Range("B" & FLLC) = FilesDates(FLLC)
'open the workbook without updating links
'and in read only mode
'it becomes the active workbook
Application.DisplayAlerts = False
Workbooks.Open FilesList(FLLC), False, True
Application.DisplayAlerts = True
On Error Resume Next
Sheets(Array(s1Name, s2Name)).PrintOut copies:=1
If Err <> 0 Then
hadErrors = True
Range("C" & FLLC) = "COULD NOT FIND/PRINT REQUESTED SHEETS"
Err.Clear
End If
On Error GoTo 0
'close the workbook, do not save changes
Application.DisplayAlerts = False
ActiveWorkbook.Close False
Application.DisplayAlerts = True
Next
If hadErrors Then
MsgBox "Processing completed, but with errors.", _
vbOKOnly + vbCritical, "Task Completed - With Errors"
Else
MsgBox "All sheets have been printed.", _
vbOKOnly + vbInformation, "Task Completed"
End If
End Sub

Private Sub QuickSortNumbers(varray As Variant, _
inLow As Long, inHigh As Long)
'thanks to
'http://vbnet.mvps.org/index.html?code/main/index.html
'for this code
Dim pivot As Long
Dim tmpSwap As Long
Dim tmpLow As Long
Dim tmpHigh As Long
tmpLow = inLow
tmpHigh = inHigh
pivot = varray((inLow + inHigh) / 2)
While (tmpLow <= tmpHigh)
While (varray(tmpLow) < pivot _
And tmpLow < inHigh)
tmpLow = tmpLow + 1
Wend
While (pivot < varray(tmpHigh) _
And tmpHigh > inLow)
tmpHigh = tmpHigh - 1
Wend
If (tmpLow <= tmpHigh) Then
tmpSwap = varray(tmpLow)
varray(tmpLow) = varray(tmpHigh)
varray(tmpHigh) = tmpSwap
tmpLow = tmpLow + 1
tmpHigh = tmpHigh - 1
End If
Wend

If (inLow < tmpHigh) Then
QuickSortNumbers varray, inLow, tmpHigh
End If

If (tmpLow < inHigh) Then
QuickSortNumbers varray, tmpLow, inHigh
End If
End Sub