Copy/Paste Clipboard in VBA

The attached Workbook which contains a sheet with two pivot tables. I want to convert the pivot tables into normal tables, so the source data is no longer linked. I'm using this technique manually but want to convert it into a macro:

1. Select the pivot table cells and press Ctrl+C to copy the range.
2. Use Paste Special to Paste Values.
3. Display the Office Clipboard.
4. With the unlinked pivot selected, click the item on the Office Clipboard that corresponds to the pivot table copy operation. It will be the last item, unless you copied something else.

I went through the steps and recorded the actions to give me this:

Sub PasteClipboard()

    Range("B4:F9").Select
    Selection.Copy
    Range("B4").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveSheet.Paste
End Sub

However if I then attempt to run the macro on my original pivot tables I get and error (highlighted in red in the code above). Is there anyway to resolve this?

Many thanks

Hi Leith,

Okay, though the element missing is the 'Paste Format' from the clipboard, step 4 on the orignal post, this puts the original formatting back onto the table of pasted values. This is what I would like to try and achieve through the macro if it is possible?

Many thanks

I've constructed this code from various sources which copies specified worksheets from a Workbook to a new Workbook using Paste Values. The only element I can't figure out is how to paste the pivot table formats. This is my code:

Sub PasteValues()

    Dim ws As Worksheet
    Dim wb As Workbook, wbNew As Workbook
         
    With Application
        .ScreenUpdating = False
                                   
        Set wb = ThisWorkbook
            wb.Worksheets(Array("Pivot", "Blue", "Green")).Copy
        Set wbNew = ActiveWorkbook
                 
        For Each ws In ActiveWorkbook.Worksheets
        
            ws.Cells.Copy
            ws.[A1].PasteSpecial Paste:=xlValues
            Application.CutCopyMode = False
            Cells(1, 1).Select
            ws.Activate
        Next ws
        Cells(1, 1).Select
                  
        .ScreenUpdating = True
    End With
    
    wbNew.SaveAs "C:\Client Jobs\Excel Solutions\My New Workbook.xlsx"
     
End Sub

I've tried adding the code in red but I can't seem to get it to paste the pivot table format, i.e. Paste Clipboard, can anyone please assist?

Sub PasteValues()

    Dim ws As Worksheet
    Dim wb As Workbook, wbNew As Workbook
    
    Dim pt As PivotTable
    Dim NextRow As Range
    Set pt = ActiveSheet.PivotTables(1)

          
    With Application
        .ScreenUpdating = False
                                   
        Set wb = ThisWorkbook
            wb.Worksheets(Array("Pivot", "Blue", "Green")).Copy
        Set wbNew = ActiveWorkbook
                 
        For Each ws In ActiveWorkbook.Worksheets
        
            ws.Cells.Copy
            ws.[A1].PasteSpecial Paste:=xlValues
            Application.CutCopyMode = False
            Cells(1, 1).Select
            ws.Activate
        Next ws
        Cells(1, 1).Select
        
        Set NextRow = ws.Cells(Cells.Rows.Count).End(xlUp).Offset(1)
            For Each pt In ws.PivotTables
            pt.TableRange2.Copy
            Set CurrentRow = NextRow
            CurrentRow.Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            Application.CutCopyMode = False
            CurrentRow.Select
            Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            Application.CutCopyMode = False
        Next pt
                  
        .ScreenUpdating = True
    End With
    
    wbNew.SaveAs "C:\Client Jobs\Excel Solutions\My New Workbook.xlsx"
     
End Sub

Many thanks

Maybe :

Sub Test()
  Dim pt As PivotTable, rng As Range
  With Worksheets.Add
    For Each pt In Sheets("Pivot").PivotTables
      .Cells.Clear: Set rng = pt.TableRange2: rng.Copy
      .Range("A1").PasteSpecial (xlPasteValues)
      .Range("A1").PasteSpecial (xlPasteFormats)
      rng.Clear: .Range("A1").CurrentRegion.Copy rng
      rng.Parent.ListObjects.Add xlSrcRange, rng, , xlYes
    Next pt
    Application.DisplayAlerts = False: .Delete: Application.DisplayAlerts = True
  End With
End Sub

Hi karedog,

How would I amalgamate this with my main piece of code, which is copying other worksheets to the new workbook. Sorry, I'm still very new to VBA?

Many thanks

I've attempted to integrate your code with my code but I can't get the paste formats for the pivots to work, even though it works with your standalone code, what am I doing wrong?

Sub PasteValues()

    Dim ws As Worksheet
    Dim wb As Workbook, wbNew As Workbook
    Dim pt As PivotTable, rng As Range
  
    With Application
        .ScreenUpdating = False
                                   
        Set wb = ThisWorkbook
            wb.Worksheets(Array("Pivot", "Blue", "Green")).Copy
        Set wbNew = ActiveWorkbook
                 
        For Each ws In ActiveWorkbook.Worksheets
        
            ws.Cells.Copy
            ws.[A1].PasteSpecial Paste:=xlValues
            Application.CutCopyMode = False
            Cells(1, 1).Select
            ws.Activate
        Next ws
        Cells(1, 1).Select
  
        For Each pt In Sheets("Pivot").PivotTables
            .Cells.Clear: Set rng = pt.TableRange2: rng.Copy
            .Range("A1").PasteSpecial (xlPasteValues)
            .Range("A1").PasteSpecial (xlPasteFormats)
            rng.Clear: .Range("A1").CurrentRegion.Copy rng
            rng.Parent.ListObjects.Add xlSrcRange, rng, , xlYes
        Next pt 
                  
        .ScreenUpdating = True
    End With
    
    wbNew.SaveAs "C:\Client Jobs\Excel Solutions\My New Workbook.xlsx"
     
End Sub

Originally Posted by HangMan

Hi karedog,
.... Sorry, I'm still very new to VBA?
Many thanks

You are welcome HangMan.
Me too

Sub Test2()
  Dim wb As Workbook, ws As Worksheet, pt As PivotTable, arr, rng As Range, i As Long
  Application.ScreenUpdating = False: Application.DisplayAlerts = False
  Set wb = Workbooks.Add: Set ws = wb.Worksheets(1): arr = Array("Pivot", "Red", "Green")
  ThisWorkbook.Worksheets(arr).Copy Before:=ws
  For i = 1 To UBound(arr) + 1
    For Each pt In Worksheets(i).PivotTables
      ws.Cells.Clear: Set rng = pt.TableRange2: rng.Copy
      ws.Range("A1").PasteSpecial (xlPasteValues)
      ws.Range("A1").PasteSpecial (xlPasteFormats)
      rng.Clear: ws.Range("A1").CurrentRegion.Copy rng
      rng.Parent.ListObjects.Add xlSrcRange, rng, , xlYes
    Next pt
  Next i
  i = UBound(arr) + 2: While wb.Worksheets.Count >= i: wb.Worksheets(i).Delete: Wend
  wb.SaveAs "C:\Client Jobs\Excel Solutions\My New Workbook.xlsx": wb.Close
  Application.ScreenUpdating = True: Application.DisplayAlerts = True
End Sub

Maybe :

Sub Test3()
  Dim wb As Workbook, ws As Worksheet, pt As PivotTable, arr, rng As Range, i As Long
  Application.ScreenUpdating = False: Application.DisplayAlerts = False
  Set wb = Workbooks.Add: arr = Array("Pivot", "Red", "Green")
  ThisWorkbook.Worksheets(arr).Copy Before:=wb.Worksheets(1)
  For i = LBound(arr) To UBound(arr)
    ThisWorkbook.Worksheets(arr(i)).Cells.Copy: wb.Worksheets(arr(i)).Cells(1, 1).PasteSpecial (xlPasteValues)
    For Each pt In ThisWorkbook.Worksheets(arr(i)).PivotTables
      pt.TableRange2.Copy: wb.Worksheets(arr(i)).Range(pt.TableRange2.Address).PasteSpecial (xlPasteFormats)
    Next pt
    wb.Worksheets(arr(i)).Select: ActiveSheet.Cells(1, 1).Select
  Next i
  i = UBound(arr) + 2: While wb.Worksheets.Count >= i: wb.Worksheets(i).Delete: Wend
  wb.SaveAs "C:\Client Jobs\Excel Solutions\My New Workbook.xlsx": wb.Close
  Application.ScreenUpdating = True: Application.DisplayAlerts = True
End Sub

From the Excel help file :
Application.GetSaveAsFilename Method
Displays the standard Save As dialog box and gets a file name from the user without actually saving any files.

The GetSaveAsFilename only get the string of the filename, it doesn't save, you must call the save method seperately.

Sub Test4()
  Dim wb As Workbook, pt As PivotTable, arr, i As Long, fileSaveName
  Application.ScreenUpdating = False: Application.DisplayAlerts = False
  Set wb = Workbooks.Add: arr = Array("Pivot", "Red", "Green")
  ThisWorkbook.Worksheets(arr).Copy Before:=wb.Worksheets(1)
  For i = LBound(arr) To UBound(arr)
    ThisWorkbook.Worksheets(arr(i)).Cells.Copy: wb.Worksheets(arr(i)).Cells(1, 1).PasteSpecial (xlPasteValues)
    For Each pt In ThisWorkbook.Worksheets(arr(i)).PivotTables
      pt.TableRange2.Copy: wb.Worksheets(arr(i)).Range(pt.TableRange2.Address).PasteSpecial (xlPasteFormats)
    Next pt
    wb.Worksheets(arr(i)).Select: ActiveSheet.Cells(1, 1).Select
  Next i
  i = UBound(arr) + 2: While wb.Worksheets.Count >= i: wb.Worksheets(i).Delete: Wend
  Application.ScreenUpdating = True: Application.DisplayAlerts = True
  Do
    fileSaveName = Application.GetSaveAsFilename(InitialFileName:="C:\My New Workbook.xlsx", fileFilter:="Excel workbook (*.xlsx), *.xlsx")
    If fileSaveName <> False Then If Len(Dir(fileSaveName)) Then MsgBox "File already exist, please choose another filename" Else Exit Do
  Loop
  wb.SaveAs fileSaveName: wb.Close
End Sub

Okay, excellent, that is ideal, the only problem now seems to be that if the user hits 'Cancel' instead of 'Save' they can't actually 'Cancel' and make the 'Save As' dialogue window go away? Is there a simple addition to the code to achieve this?

Also, if they do decide they 'do' want to overwrite the existing file by selecting 'Save', they can't because it invokes the 'This File Already Exists' message.

This would need to be a warning that they are about to overwrite the existing file, so they should be able to say 'Yes' and overwrite the file or Rename the file if they don't want to overwrite the existing file or hit 'Cancel' to close the Save As dialogue window altogether without doing either...

Is this possible to achieve?

Many thanks

This is my last post on this thread.

Sub Test5()
  Dim wb As Workbook, pt As PivotTable, arr, i As Long, fileSaveName
  Application.ScreenUpdating = False: Application.DisplayAlerts = False
  Set wb = Workbooks.Add: arr = Array("Pivot", "Red", "Green")
  ThisWorkbook.Worksheets(arr).Copy Before:=wb.Worksheets(1)
  For i = LBound(arr) To UBound(arr)
    ThisWorkbook.Worksheets(arr(i)).Cells.Copy: wb.Worksheets(arr(i)).Cells(1, 1).PasteSpecial (xlPasteValues)
    For Each pt In ThisWorkbook.Worksheets(arr(i)).PivotTables
      pt.TableRange2.Copy: wb.Worksheets(arr(i)).Range(pt.TableRange2.Address).PasteSpecial (xlPasteFormats)
    Next pt
    wb.Worksheets(arr(i)).Select: ActiveSheet.Cells(1, 1).Select
  Next i
  i = UBound(arr) + 2: While wb.Worksheets.Count >= i: wb.Worksheets(i).Delete: Wend
  Application.ScreenUpdating = True: Application.DisplayAlerts = True
  fileSaveName = Application.GetSaveAsFilename(InitialFileName:="C:\My New Workbook.xlsx", fileFilter:="Excel workbook (*.xlsx), *.xlsx")
  On Error Resume Next: If fileSaveName <> False Then wb.SaveAs fileSaveName
End Sub

Regards

Hi karedog,

That fixed the cancel problem, there is still a slight problem with the 'Save As' but I appreciate you've spent a long time helping me out with this and this was your last post. Your help is hugely appreciated and there is no way I would have been able to get this far without your help, so thank you...

I'll try and figure out the last little bit on my own.

Many many thanks