Loop Items in Pivot Filter and Paste into new sheet

[Martin sherk]

The below code filters my pivot table by company codes criteria and copies the result to new workbooks named after each company code.

What I want:

1. Copy the result to new sheets within the current workbook in new sheets not to new workbooks.
2. Name the worksheets after the filtered base which is the company code.
3. copy the pivot itself to the new sheets not copy and paste special (or just copy data without the pivot).

Code:

Option Explicit
Sub GetAllEmployeeSelections()

    'Const filePath As String = "C:\Users\User\Desktop\" 'save location for new files

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim pvt As PivotTable


    Set wb = ActiveWorkbook
    Set ws = wb.Worksheets("PivotTable")
    Set pvt = ws.PivotTables("PivotTable1")
pvt.PivotCache.MissingItemsLimit = xlMissingItemsNone

    Application.ScreenUpdating = False

    Dim pvtField As PivotField
    Dim item As Long
    Dim item2 As Long

    Set pvtField = pvt.PivotFields("Company Code")

    For item = 1 To pvtField.PivotItems.Count

          pvtField.PivotItems(item).Visible = True

          For item2 = 1 To pvtField.PivotItems.Count

              If item2 <> item Then pvtField.PivotItems(item2).Visible = False

          Next item2

        Dim newBook As Workbook
        Set newBook = Workbooks.Add

        With newBook

            Dim currentName As String
            currentName = pvtField.PivotItems(item).Name

            .Worksheets(1).Name = currentName

            pvt.TableRange2.Copy

            Worksheets(currentName).Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats

           '.SaveAs Filename:=filePath & currentName & ".xlsx"

           '.Close

        End With

        'Set newBook = Nothing

    Next item

    Application.ScreenUpdating = True

End Sub