PIVOT FILTER - PASTE INTO NEW SHEET

[shahzeb123]

Guys,

I am back.

I need your help now, I have data of 22k rows now I have used Pivot to sort the data.

I am using the below code where I filter the data this code will paste it into another sheet.

What I want to do is to that VBA code where it will filter the data automatically by column A when there is a total in column "A" aka RGM column

When there is a total it should copy this into another sheet with the name of as written in the last.

and it should do this with all the RGM column total

If any of you can help me so please do I am in dire need. I am here waiting for your response

Sub PivotCopyFormatValues()
'select pivot table cell first
Dim ws As Worksheet
Dim pt As PivotTable
Dim rngPT As Range
Dim rngPTa As Range
Dim rngCopy As Range
Dim rngCopy2 As Range
Dim lRowTop As Long
Dim lRowsPT As Long
Dim lRowPage As Long
Dim msgSpace As String

On Error Resume Next
Set pt = ActiveCell.PivotTable
Set rngPTa = pt.PageRange
On Error GoTo errHandler

If pt Is Nothing Then
    MsgBox "Could not copy pivot table for active cell"
    GoTo exitHandler
End If

If pt.PageFieldOrder = xlOverThenDown Then
  If pt.PageFields.Count > 1 Then
    msgSpace = "Horizontal filters with spaces." _
      & vbCrLf _
      & "Could not copy Filters formatting."
  End If
End If

Set rngPT = pt.TableRange1
lRowTop = rngPT.Rows(1).Row
lRowsPT = rngPT.Rows.Count
Set ws = Worksheets.Add
Set rngCopy = rngPT.Resize(lRowsPT - 1)
Set rngCopy2 = rngPT.Rows(lRowsPT)

rngCopy.Copy Destination:=ws.Cells(lRowTop, 1)
rngCopy2.Copy _
  Destination:=ws.Cells(lRowTop + lRowsPT - 1, 1)

If Not rngPTa Is Nothing Then
    lRowPage = rngPTa.Rows(1).Row
    rngPTa.Copy Destination:=ws.Cells(lRowPage, 1)
End If
    
ws.Columns.AutoFit
If msgSpace <> "" Then
  MsgBox msgSpace
End If

exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not copy pivot table for active cell"
    Resume exitHandler
End Sub

 

[GlennUK]

This is getting too confusing. Is that the code that copies the format just as you want? Or is it code that should copy formats but doesn't?

 

[shahzeb123]

I am sorry if I made it too confusing.

Just understand this, the below code will copy all the data with the formats and paste it into existing sheets.

I want you to change the code just that it should copy all the data and paste it into new workbooks.

SORRY again!

        Sub Button2_Click()
 
Dim PT As PivotTable
Dim PI As PivotItem
Dim PI2 As PivotItem
 
'1)Worksheet name where PIVOT Table is located
MyWs = "SUMMARY"
'2)PIVOT table name/number, note by default the first one created is PivotTable1
MyPIV = "PivotTable1"
'3)Field Name that you want to use for breaking out by, i.e. the filter name
MyField = "RGM"
 
Set PT = Worksheets(MyWs).PivotTables(MyPIV)
With PT
 
For Each PI In Worksheets(MyWs).PivotTables(MyPIV).PivotFields(MyField).PivotItems
PI.Visible = True
 
For Each PI2 In Worksheets(MyWs).PivotTables(MyPIV).PivotFields(MyField).PivotItems
If Not PI2.Name = PI.Name Then PI2.Visible = False
Next PI2


 
'You will need to amend the range below to copy the correct amount of data for your file
Set rngPT = PT.TableRange1
lRowTop = rngPT.Rows(1).Row
lRowsPT = rngPT.Rows.Count
Set ws = Worksheets.Add
Set rngCopy = rngPT.Resize(lRowsPT - 1)
Set rngCopy2 = rngPT.Rows(lRowsPT)
ws.Name = PI

rngCopy.Copy Destination:=ws.Cells(lRowTop, 1)
rngCopy2.Copy _
Destination:=ws.Cells(lRowTop + lRowsPT - 1, 1)
ws.Columns.AutoFit
 
'This pastes into cell A1 of the new sheet

Next PI
End With
End Sub

 

[shahzeb123]

This is getting too confusing. Is that the code that copies the format just as you want? Or is it code that should copy formats but doesn't?

However, for the record, it is the code that copies my format !