Merging vba - Sheet copy and Table of contents

[exceljen86]

Hi all,

I've got two sections of vba code that work well on their own, but I need to merge to make them work how I need them to.

The first section of code below looks for a Y in a particular box and copies the linked sheets into a new workbook. The second creates a table of contents.

    Sub CopySheets()    Dim rng       As Range
    Dim c         As Range
    Dim LookupLO  As ListObject
    Dim RefCol    As Object
    Dim WS        As Worksheet
    Dim wb1       As Workbook
    Dim Wb2       As Workbook
    Dim ShtStr    As String
    Dim ShtArr    As Variant
    Dim i         As Long


    Set wb1 = ThisWorkbook
    Set LookupLO = wb1.Sheets("Input").ListObjects("SheetsTbl")
    Set rng = wb1.Sheets("Input").Range("D15:D39")
    Set RefCol = CreateObject("Scripting.Dictionary")


    For Each c In rng
        If LCase(c.Value) = "y" Then RefCol(c.Address(False, False)) = vbNullString
    Next c


    For i = 1 To LookupLO.DataBodyRange.Rows.Count
        If RefCol.Exists(CStr(LookupLO.ListColumns("Cell Ref").Range(i))) Then
            On Error Resume Next
            Set WS = wb1.Sheets(LookupLO.ListColumns("Sheet Name").Range(i).Value)
            On Error GoTo 0
            If Not WS Is Nothing Then ShtStr = ShtStr & LookupLO.ListColumns("Sheet Name").Range(i) & ","
            Set WS = Nothing
        End If
    Next i


    If ShtStr <> "" Then
        ShtStr = Left(ShtStr, Len(ShtStr) - 1)
        ShtArr = Split(ShtStr, ",")
    
        Set Wb2 = Workbooks.Add
        wb1.Sheets(ShtArr).Copy Before:=Wb2.Sheets(1)
    Else
        MsgBox "No Sheets to Copy"
   
Application.DisplayAlerts = False
On Error Resume Next
ThisWorkbook.Sheets("Sheet1").Delete
On Error GoTo 0
Application.DisplayAlerts = True


Application.DisplayAlerts = False
On Error Resume Next
ThisWorkbook.Sheets("Sheet2").Delete
On Error GoTo 0
Application.DisplayAlerts = True


Application.DisplayAlerts = False
On Error Resume Next
ThisWorkbook.Sheets("Sheet3").Delete
On Error GoTo 0
Application.DisplayAlerts = True


    End If
    Application.PrintCommunication = True


End Sub

Sub CreateTableOfContents()
    ' Determine if there is already a Table of Contents
    ' Assume it is there, and if it is not, it will raise an error
    ' if the Err system variable is > 0, you know the sheet is not there
    Dim WS As Worksheet
    On Error Resume Next
    Set WS = Worksheets("TOC")
    If Not Err = 0 Then
        ' The Table of contents doesn't exist. Add it
        Set WS = Worksheets.Add(Before:=Worksheets(1))
        WS.Name = "TOC"
    End If
    On Error GoTo 0
     
    ' Set up the table of contents page
    WS.[A2] = "Table of Contents"
    With WS.[A6]
        .CurrentRegion.Clear
        .Value = "Subject"
    End With
    WS.[B6] = "Page(s)"
    WS.Range("A1:B1").ColumnWidth = Array(36, 12)
    TOCRow = 7
    PageCount = 0
 
    ' Do a print preview on all sheets so Excel calcs page breaks
    ' The user must manually close the PrintPreview window
    Msg = "Excel needs to do a print preview to calculate the number of pages. "
    Msg = Msg & "Please dismiss the print preview by clicking close."
    MsgBox Msg
    ActiveWindow.SelectedSheets.PrintPreview
 
    ' Loop through each sheet, collecting TOC information
    For Each S In Worksheets
        If S.Visible = -1 Then
            S.Select
            ThisName = ActiveSheet.Name
            HPages = ActiveSheet.HPageBreaks.Count + 1
            VPages = ActiveSheet.VPageBreaks.Count + 1
            ThisPages = HPages * VPages
 
            ' Enter info about this sheet on TOC
            Sheets("TOC").Select
            Range("A" & TOCRow).Value = ThisName
            Range("B" & TOCRow).NumberFormat = "@"
            If ThisPages = 1 Then
                Range("B" & TOCRow).Value = PageCount + 1 & " "
            Else
                Range("B" & TOCRow).Value = PageCount + 1 & " - " & PageCount + ThisPages
            End If
        PageCount = PageCount + ThisPages
        TOCRow = TOCRow + 1
        End If
    Next S
End Sub

The problem that I've got is that I need to figure out how to select the sheets, put them into the TOC and then copy them (including the TOC) to the second workbook, as the TOC code won't run on the new workbook.

Can anyone help please?

Thanks in advance

 

[exceljen86]

Still stuck... can anyone help pleeeeaaaasssseee