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

 

[shahzeb123]

I will wait for your command.

Thanks for making time!

 

[GlennUK]

It would be something like this (my Pivot Page Filter field is INTENT - move your required field to the Pivot Page Filter area, and change the INTENT to your field name in the code):

Sub genpt()
'
    Set currsht = ActiveSheet
    ActiveSheet.PivotTables("PivotTable1").ShowPages PageField:="INTENT"
    For Each wksht In ThisWorkbook.Worksheets
        If wksht.Name <> currsht.Name Then
        If wksht.Range("A1") = "INTENT" Then
            Set wbknew = Workbooks.Add
            ThisWorkbook.Activate
            wksht.Activate
            wksht.UsedRange.Copy
            wbknew.Activate
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
            Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
            Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
            ActiveWorkbook.SaveAs Filename:="C:\Users\Glenn\Documents\Excel\" & wbknew.Sheets(1).Range("B1").Value & ".xlsx", _
            FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
            ActiveWorkbook.Close
            ThisWorkbook.Activate
        End If
        End If
    Next
End Sub

 

[shahzeb123]

 If wksht.Name <> currsht.Name Then

The above code comes with an error.

However, when I removed this, it worked smoothly.

Really appreciate the effort you put into this work.

A little request more it copies everything in value but without format. can you please tweak it so it copies with format?

THANK YOU SOO MUCH !!! )))

 

[shahzeb123]

Just wanted to know out of the curiosity,

Can I have a dialog box before saving the file for asking the location where to save it?

If you do not want to respond ill understand.

 

[GlennUK]

 If wksht.Name <> currsht.Name Then

The above code comes with an error.

However, when I removed this, it worked smoothly.

Really appreciate the effort you put into this work.

A little request more it copies everything in value but without format. can you please tweak it so it copies with format?

THANK YOU SOO MUCH !!! )))

Glad to help. But the macro copied formats - what is it about formats that is not getting copied on your setup? As for a dialog - if the files are all to go in the same folder, then you need to capture that before the looping.

 

[shahzeb123]

Yeah, i have read the codes.

But that is the problem with Pivot when you copy Pivot report and paste it manually by formats and values it will not paste the formats.

Because of that I first used my below code. which will copy the active sheet with current format and paste it into new sheet.

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]

Well, use that same logic in the new code.

 

[shahzeb123]

i am trying but cant merge these two

 

[GlennUK]

Well, you must know what part of your code copies the formats you want. Can you paste that here?

 

[shahzeb123]

The below part seems that it copies the format.

If I am wrong I am sorry.

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