Macro to Save Certain Sheets of 3 WBs as a Single PDF File

[Serkan77]

Hi. I'm a teacher. At school, I have 3 workbooks in the same folder. “Students.xls” and “Classrooms.xls” are connected to “Main.xls”.

1. “Main.xls” does all the job. It has some macros and 7 worksheets. (We use it to organize the exams.)
2. “Students.xls” has 30 worksheets.
3. “Classrooms.xls” has 60 worksheets.

I work only with “Main.xls” . I don’t open the other two workbooks, there are empty lists in them. I enter some data in the “Main.xls” and run the macros. The macros fill the required amount of worksheets in the “Students.xls” and “Classrooms.xls” then colour the sheet tabs of the used worksheets. When I run the PRINT macro, it prints:

1. “Numbers1” and “Numbers2” sheets in the “Main.xls”
2. The used worksheets in the “Students.xls” and “Classrooms.xls” (the PRINT macro is coded for printing the coloured sheets only.)

Now, what I want to do is, saving these printable worsheets in 3 different workbooks as a single *.pdf file with a one click macro button.
Here is the PRINT macro.

Sub PrintTheLists()
'It prints the used lists and numbers.
 
Dim i As Integer, j As Integer, k As Integer
If Worksheets("Numbers1").Cells(3, 2).Value = "" Or Worksheets("Numbers2").Cells(3, 2).Value = "" Then
    MsgBox "Please prepare the lists first"
Else
'ThisWorkbook.Activate
Worksheets("Numbers1").PrintOut
Worksheets("Numbers2").PrintOut
 
Workbooks.Open ThisWorkbook.Path & "\" & "Students.xls"
For i = 1 To 30
    If Workbooks("Students.xls").Worksheets(i).Tab.ColorIndex = 4 Then
        k = k + 1
    End If
Next i
With Workbooks("Students.xls").Worksheets
                                .PrintOut From:=1, To:=k
End With
Workbooks("Students.xls").Close
Workbooks.Open ThisWorkbook.Path & "\" & "Classrooms.xls"
For i = 1 To 60
    If Workbooks("Classrooms.xls").Worksheets(i).Tab.ColorIndex = 3 Then
        k = k + 1
    End If
Next i
With Workbooks("Classrooms.xls").Worksheets
                                .PrintOut From:=1, To:=k
End With
Workbooks("Classrooms.xls").Close
End If
End Sub

I’m not good at macros. I need your help.
Thanks in advance.

 

[pbornemeier]

This code should be placed in a standard module in the Main.xls workbook.
I changed the hard coded 30 and 60 to a value that is calculated when each workbook is opened to allow for more flexability. This can be changed if required.

Sub CertainSheetsFrom3WorkbooksToPDF()

    Dim sNewFileName As String
    Dim lNewFileSheetCount As Long
    Dim arySheets()
    Dim lAddCount As Long
    Dim sFilePath As String
    Dim sFileName As String
    Dim vFilePathName As Variant
    Dim lNameStarts As Long
    Dim sFileNameExt As String
    Dim lExtensionStarts As Long
    Dim sFileExt As String
    Dim lX As Long
    
    ThisWorkbook.Activate
    
    If Worksheets("Numbers1").Cells(3, 2).Value = "" Or Worksheets("Numbers2").Cells(3, 2).Value = "" Then
        MsgBox "Please prepare the lists first"
    Else
        
        'Set default location and filename
        sFilePath = ThisWorkbook.Path
        sFileName = Format(Now(), "yyyymmdd") & " Student-Classroom Report"
        
        'Select the location and enter the name of the new file
        vFilePathName = Application.GetSaveAsFilename(sFileName, _
            FileFilter:="PDF Files (*.pdf), *.pdf", Title:="Select location and name for new file")
        If vFilePathName = False Then GoTo End_Sub

        Workbooks.Add   'Create a new workbook
        sNewFileName = ActiveWorkbook.Name
        lNewFileSheetCount = ActiveWorkbook.Sheets.Count
        
        'Copy Numbers1 & Numbers2 worksheets from this workbook
        ThisWorkbook.Worksheets("Numbers1").Copy _
            After:=Workbooks(sNewFileName).Sheets(Workbooks(sNewFileName).Sheets.Count)
        ThisWorkbook.Worksheets("Numbers2").Copy _
            After:=Workbooks(sNewFileName).Sheets(Workbooks(sNewFileName).Sheets.Count)
        
        'Copy Green sheets from Students.xls
        Workbooks.Open ThisWorkbook.Path & "\" & "Students.xls"
        For lX = 1 To ActiveWorkbook.Sheets.Count 'Was 30
            If Workbooks("Students.xls").Worksheets(lX).Tab.ColorIndex = 4 Then
                Workbooks("Students.xls").Worksheets(lX).Copy _
                    After:=Workbooks(sNewFileName).Sheets(Workbooks(sNewFileName).Sheets.Count)
            End If
        Next lX
        Workbooks("Students.xls").Close
        
        'Copy Red Sheets from Classrooms.xls
        Workbooks.Open ThisWorkbook.Path & "\" & "Classrooms.xls"
        For lX = 1 To ActiveWorkbook.Sheets.Count 'Was 60
            If Workbooks("Classrooms.xls").Worksheets(lX).Tab.ColorIndex = 3 Then
                Workbooks("Classrooms.xls").Worksheets(lX).Copy _
                    After:=Workbooks(sNewFileName).Sheets(Workbooks(sNewFileName).Sheets.Count)
            End If
        Next lX
        Workbooks("Classrooms.xls").Close
        
        'Delete blank sheets that were created with new workbook
        If Workbooks(sNewFileName).Sheets.Count > lNewFileSheetCount Then
            For lX = lNewFileSheetCount To 1 Step -1
                Application.DisplayAlerts = False
                Workbooks(sNewFileName).Sheets(lX).Delete
                Application.DisplayAlerts = True
            Next
        End If
        
        lNameStarts = InStrRev(vFilePathName, "\")
        sFilePath = Left(vFilePathName, lNameStarts)
        sFileNameExt = Mid(vFilePathName, lNameStarts + 1)
        lExtensionStarts = InStrRev(sFileNameExt, ".")
        sFileName = Left(sFileNameExt, lExtensionStarts - 1)
        sFileExt = Mid(sFileNameExt, lExtensionStarts + 1)
        
        With Workbooks(sNewFileName)
            For lX = 1 To .Sheets.Count
                lAddCount = lAddCount + 1
                ReDim Preserve arySheets(1 To lAddCount)
                arySheets(lAddCount) = .Sheets(lX).Name
            Next
            .Sheets(arySheets).Select
            .Sheets(arySheets(1)).ExportAsFixedFormat Type:=xlTypePDF, _
                Filename:=sFilePath & sFileName & ".pdf", _
                Quality:=xlQualityStandard, IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, OpenAfterPublish:=True
        End With
        
    End If
    
End_Sub:

End Sub