VBA to copy paste data form a pivot to a new sheet, and also keep the formatting

[justme101]

Hello experts,

I am copying a pivot data from one sheet, and pasting as values to a new sheet, and I also want to keep the formatting, which I am unable to do. The code is given below. It is copying and pasting the data, but not the format. I also tried another way to format the cells, towards the later part of the code, but that formats every cell in the column J, not the specific ones which start with a 'letter'.

PLEASE NOTE: Every time this code gets executed it creates a new sheet and the values from the INVOICE DETAILS sheet is copy pasted to a new sheet, which I am sure you guys would have figured out.

Sub Save()

Dim wb As Workbook, ws As Worksheet

ThisWorkbook.Worksheets("Invoice details").Activate

For Each cell In Range("F5")
    If cell.Value <> 0 Then
        MsgBox ("The values in E4 & E5 are not matching. Please check")
    GoTo X
        End If
    Next
   
If WorksheetFunction.CountA(Range("E1:E5")) = 0 Then
        MsgBox ("The values in E1 to E5 cannot be blank. Please check")
    GoTo X
        End If
       
'Copy and Paste to new sheet

    Sheets("B Invoice details").Cells.Copy
   
    Sheets.Add(After:=Sheets("Invoice details")).Name = Range("E1").Value
   
    ActiveSheet.Cells.PasteSpecial Paste:=xlPasteValues
    ActiveSheet.Cells.PasteSpecial Paste:=xlPasteFormats
   
    Dim c As Range
   
    For Each c In ActiveSheet.UsedRange.Columns("J").Cells
        If Left(c.Value, 1) <> "#*" Then
             c.Font.Bold = True
        Else
        End If
    Next c
   
       
    Application.CutCopyMode = False
   
X:
End Sub

 

[Alex Blakenburg]

See if this works for you:

Sub Save()

    Dim wb As Workbook
    Dim mainSht As Worksheet, srcSht As Worksheet, destSht As Worksheet
    Dim cell As Range
    
    Set wb = ThisWorkbook
    Set mainSht = wb.Worksheets("Invoice details")
    mainSht.Activate

    For Each cell In Range("F5")
        If cell.Value <> 0 Then
            MsgBox ("The values in E4 & E5 are not matching. Please check")
            GoTo X
        End If
    Next
   
    If WorksheetFunction.CountA(Range("E1:E5")) = 0 Then
        MsgBox ("The values in E1 to E5 cannot be blank. Please check")
        GoTo X
    End If
       
'Copy and Paste to new sheet
    Set srcSht = wb.Worksheets("B Invoice details")
    
    srcSht.Cells.Copy
   
    Sheets.Add(After:=Sheets("Invoice details")).Name = Range("E1").Value
    Set destSht = ActiveSheet
   
    With destSht
        .Cells.PasteSpecial Paste:=xlPasteValues
        .Cells.PasteSpecial Paste:=xlPasteFormats
        
         Dim c As Range
        
         For Each c In .UsedRange.Columns("J").Cells
             If Left(c.Value, 1) <> "#*" Then
                  c.Font.Bold = True
             End If
         Next c
    End With
    
    Call PivotCopyFormatValues(srcSht:=srcSht, destSht:=destSht)
       
    Application.CutCopyMode = False
   
X:
End Sub


Private Sub PivotCopyFormatValues(srcSht As Worksheet, destSht As Worksheet)
'adapted original from:-
' http://www.contextures.com/excel-vba-pivot-table-paste-format.html#PasteCode

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 lColLeft As Long
Dim lRowsPT As Long
Dim lRowPage As Long

'  Pivot Loop
    For Each pt In srcSht.PivotTables
        On Error Resume Next
            Set rngPTa = pt.PageRange
            On Error GoTo errHandler
            
            If pt Is Nothing Then
                MsgBox "Could not copy pivot table for active cell"
                GoTo exitHandler
            Else
                Set rngPT = pt.TableRange1
                lRowTop = rngPT.Rows(1).Row
                lRowsPT = rngPT.Rows.Count
                lColLeft = rngPT.Columns(1).Column
                Set rngCopy = rngPT.Resize(lRowsPT - 1)
                Set rngCopy2 = rngPT.Rows(lRowsPT)
                
                rngCopy.Copy Destination:=destSht.Cells(lRowTop, lColLeft)
                rngCopy2.Copy Destination:=destSht.Cells(lRowTop + lRowsPT - 1, lColLeft)
            End If
            
            If Not rngPTa Is Nothing Then
                lRowPage = rngPTa.Rows(1).Row
                rngPTa.Copy Destination:=destSht.Cells(lRowPage, lColLeft)
            End If

            destSht.Columns.AutoFit
        Next pt

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

 

[justme101]

See if this works for you:

Sub Save()

    Dim wb As Workbook
    Dim mainSht As Worksheet, srcSht As Worksheet, destSht As Worksheet
    Dim cell As Range
   
    Set wb = ThisWorkbook
    Set mainSht = wb.Worksheets("Invoice details")
    mainSht.Activate

    For Each cell In Range("F5")
        If cell.Value <> 0 Then
            MsgBox ("The values in E4 & E5 are not matching. Please check")
            GoTo X
        End If
    Next
  
    If WorksheetFunction.CountA(Range("E1:E5")) = 0 Then
        MsgBox ("The values in E1 to E5 cannot be blank. Please check")
        GoTo X
    End If
      
'Copy and Paste to new sheet
    Set srcSht = wb.Worksheets("B Invoice details")
   
    srcSht.Cells.Copy
  
    Sheets.Add(After:=Sheets("Invoice details")).Name = Range("E1").Value
    Set destSht = ActiveSheet
  
    With destSht
        .Cells.PasteSpecial Paste:=xlPasteValues
        .Cells.PasteSpecial Paste:=xlPasteFormats
       
         Dim c As Range
       
         For Each c In .UsedRange.Columns("J").Cells
             If Left(c.Value, 1) <> "#*" Then
                  c.Font.Bold = True
             End If
         Next c
    End With
   
    Call PivotCopyFormatValues(srcSht:=srcSht, destSht:=destSht)
      
    Application.CutCopyMode = False
  
X:
End Sub


Private Sub PivotCopyFormatValues(srcSht As Worksheet, destSht As Worksheet)
'adapted original from:-
' http://www.contextures.com/excel-vba-pivot-table-paste-format.html#PasteCode

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 lColLeft As Long
Dim lRowsPT As Long
Dim lRowPage As Long

'  Pivot Loop
    For Each pt In srcSht.PivotTables
        On Error Resume Next
            Set rngPTa = pt.PageRange
            On Error GoTo errHandler
           
            If pt Is Nothing Then
                MsgBox "Could not copy pivot table for active cell"
                GoTo exitHandler
            Else
                Set rngPT = pt.TableRange1
                lRowTop = rngPT.Rows(1).Row
                lRowsPT = rngPT.Rows.Count
                lColLeft = rngPT.Columns(1).Column
                Set rngCopy = rngPT.Resize(lRowsPT - 1)
                Set rngCopy2 = rngPT.Rows(lRowsPT)
               
                rngCopy.Copy Destination:=destSht.Cells(lRowTop, lColLeft)
                rngCopy2.Copy Destination:=destSht.Cells(lRowTop + lRowsPT - 1, lColLeft)
            End If
           
            If Not rngPTa Is Nothing Then
                lRowPage = rngPTa.Rows(1).Row
                rngPTa.Copy Destination:=destSht.Cells(lRowPage, lColLeft)
            End If

            destSht.Columns.AutoFit
        Next pt

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

This seems to be working. Thanks a bunch! But, Now I have questions about the Private Sub you included. Would you be kind enough to give a brief explanation as to how the entire code works? and why the Private sub was created (meaning was it necessary)?

 

[Alex Blakenburg]

This seems to be working. Thanks a bunch! But, Now I have questions about the Private Sub you included. Would you be kind enough to give a brief explanation as to how the entire code works? and why the Private sub was created (meaning was it necessary)?

Copying a Pivot Table as values with the formatting is a bit quirky.
I think the best starting point for understanding the code is to understand the manual steps in copying a pivot as values and retaining the formatting.
Can you have a look at Debra Dalgleish's Contextures site where I initially got the code. Have a look at the manual process first, particulary where report filters are involved.
Excel Pivot Table Macro Paste Format Values

Come back to me if you still have questions after that.