Solved

Copying Table (pivot) to different worksheet

Posted on 2011-09-27
8
198 Views
Last Modified: 2012-05-12
Function CopyFunction()  
    Dim lEndRow As Long, lStartRow As Long  
    Dim num1 As Integer, num2 As Integer  
      
    '1st row starts from 3  
    lStartRow = 3  
      
    'last row = grand total and its not included  
    lEndRow = (Sheets("Pivots").Range("A" & Sheets("Pivots").Rows.Count).End(xlUp).Row) - 1  
      
    'First loop assingment  
    For num1 = lStartRow To lEndRow  
              
        'Second loop assignment  
        For num2 = lStartRow To lEndRow  
          
        Next  
    Next  
    MsgBox lEndRow  
End Function 

Open in new window


Hi,

I have a pivot table in a sheet called 'Pivots'

I want to create a new tab - say 'GL Summary' and paste all the pivot table entries into a table on this sheet.

Pivot table has 3 columns (Unique, Sum of Debt, Sum of Credit)

Could you please help me to code this? I am sure its going to be a one liner but looking around,  I see a lot of complext solutions. I am very sure this can be done in one line but  I am bad with ranges :/

Thanks in advance!
Copy-of-GL-Summary---Master-File.xls
0
Comment
Question by:Shanan212
  • 4
  • 3
8 Comments
 
LVL 13

Author Comment

by:Shanan212
Comment Utility
Function CopyFunction()
    Dim lEndRow As Long, lStartRow As Long
    Dim num1 As Integer, num2 As Integer
    Dim Finals As Worksheet
    
    Set Finals = Worksheets.Add()
    Finals.Name = "Payroll Summary"
    
    Range("A1").Value = "ID"
    Range("B1").Value = "Sum of Debt"
    Range("C1").Value = "Sum of Credit"
    
    '1st row starts from 3
    lStartRow = 3
    
    'last row = grand total and its not included
    lEndRow = (Sheets("Pivots").Range("A" & Sheets("Pivots").Rows.Count).End(xlUp).Row) - 1
    
    'First loop assingment
    For num1 = lStartRow To lEndRow
            
        'Second loop assignment
        For num2 = lStartRow To lEndRow
            
        Next
    Next
    
    Finals.Columns.AutoFit
    
End Function

Open in new window


I have the above table which now creates the table-to paste the pivot data.


Any help is much appreciated!
0
 
LVL 41

Expert Comment

by:dlmille
Comment Utility
Copy and pasting the pivot is simple.  However, your GL Summary looks alot more complicated.  Do you want to replace the data, do you want the data pasted in exactly as GL Summary is formed, and why not use a lookup from GL Summary into the pivot data, instead?

Given the optinos, it would be good to read your response before providing a more-focused solution.

Cheers,

Dave
0
 
LVL 13

Author Comment

by:Shanan212
Comment Utility
I only want the pivot data to be copied. Only 3 columns mentioned. I have further amended the function to delete the 'destination' worksheet and recreate a new one (so replacing)

I do want the data pased exactly as the pivot is formed.

Vlookup sounds good but the data on pivot could vary (rows) and it might look ugly

Let me know. This is what I have further compiled using internet research. But the 2 lines of codes inside the loop, I am having tough time with the '_' as my VBA is old and it wouldn't allow it. I am not quite sure how to bring it all on one line!

Any help is appreciated!

Function CopyFunction()
    Dim lEndRow As Long, lStartRow As Long
    Dim num1 As Integer, num2 As Integer
    Dim Finals As Worksheet, wssheet As Worksheet
    
    Set wssheet = Sheets("Payroll Summary")
    
    
    If Not wssheet Is Nothing Then
        Application.DisplayAlerts = False
        Worksheets("Payroll Summary").Delete
        Application.DisplayAlerts = True
    End If
     
    Set Finals = Worksheets.Add()
    Finals.Name = "Payroll Summary"
    
    Range("A1").Value = "ID"
    Range("B1").Value = "Sum of Debt"
    Range("C1").Value = "Sum of Credit"
    
    Dim strThisWs As String
    Dim wsEach As Worksheet
    Dim rngStart As Range
    Dim rngEnd As Range
    Dim rngCell As Range
    Dim rngDest As Range
    

    With Worksheets("Pivots")
    
    'set start as A2 i.e., after heading row in column A
    Set rngStart = .Range("A2")
    
    'set end - last used row in column A
    Set rngEnd = .Range("A" & CStr(Application.Rows.Count)).End(xlUp)
    
    'loop through cells in column A
    For Each rngCell In .Range(rngStart, rngEnd)
    
        'find next empty row on destination sheet
        Set rngDest = Worksheets("CPL Distance") _
                    .Range("A" & CStr(Application.Rows.Count)) _
                    .End(xlUp).Offset(1, 0)
            
        'copy & paste entire row
        rngCell.EntireRow.Copy _
                Destination:=Worksheets("CPL Distance") _
                        .Range(rngDest.Address)

        Next rngCell
    End With

    
    Finals.Columns.AutoFit
    
End Function

Open in new window

0
 
LVL 41

Accepted Solution

by:
dlmille earned 500 total points
Comment Utility
That was useful.

Here's your code.

 
Option Explicit


Sub TextBox2_Click()

 CopyFunction
 
End Sub
Sub CopyFunction()
    Dim lEndRow As Long, lStartRow As Long
    Dim num1 As Integer, num2 As Integer
    Dim wkb As Workbook
    Dim pivotSht As Worksheet, Finals As Worksheet, srcWks As Worksheet
    Dim copyRng As Range, pasteRng As Range
    
    Set wkb = ThisWorkbook
    Set pivotSht = wkb.Sheets("Pivots")
    
    'put error checking in, to ensure sheet "Payroll Summary" doesn't already exist, or you'll get an error when you set the name to the new sheet
    Set Finals = wkb.Worksheets.Add(after:=wkb.Sheets(wkb.Sheets.Count))
    Finals.Name = "Payroll Summary"
    
    Finals.Range("A1:C1") = Split("ID,Sum of Debt,Sum of Credit", ",")
    
    '1st row starts from 3
    lStartRow = 3
    
    'last row = grand total and its not included
    lEndRow = (pivotSht.Range("A" & pivotSht.Rows.Count).End(xlUp).Row) - 1
    
    Set copyRng = pivotSht.Range("A" & lStartRow, pivotSht.Range("C" & lEndRow))
    Set pasteRng = Finals.Range("A2")
    
    'copy values only, not formats
    pasteRng.Resize(copyRng.Rows.Count, copyRng.Columns.Count).Value = copyRng.Value
    
    'alternatively,copy with formats
    'copyRng.Copy
    'pasteRng.PasteSpecial xlPasteAll
    'Application.CutCopyMode = False
    
    Finals.Columns.AutoFit
    
End Sub

Open in new window


See attached, and run the copyFunction subroutine to get results.  Note comments in code, re: error checking needed.

Cheers,

Dave
Copy-of-GL-Summary---Master-File.xls
0
IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

 
LVL 41

Expert Comment

by:dlmille
Comment Utility
here's the code for determining whether a sheet exists, or not:

dim tstWks as worksheet

    on error resume next
    set tstWks = sheets("Payroll Summary")
    if error.number <> 0 then 'got an error, so sheet must not exist
         'add the worksheet
    end if
    on error goto 0 'reset error trapping

Cheers,

Dave
0
 
LVL 41

Expert Comment

by:dlmille
Comment Utility
You don't need to iterate through every row to do the copy.  The code I posted will work, it is tested, and a copy/paste (or range assignment as I did) can be done with an entire range.

Here's what you need to do with the "_":

        Set rngDest = Worksheets("CPL Distance") _
                    .Range("A" & CStr(Application.Rows.Count)) _
                    .End(xlUp).Offset(1, 0)
           
        'copy & paste entire row
        rngCell.EntireRow.Copy _
                Destination:=Worksheets("CPL Distance") _
                        .Range(rngDest.Address)



becomes:

        Set rngDest = Worksheets("CPL Distance").Range("A" & CStr(Application.Rows.Count)).End(xlUp).Offset(1, 0)
           
        'copy & paste entire row
        rngCell.EntireRow.Copy  Destination:=Worksheets("CPL Distance").Range(rngDest.Address)


Cheers,

Dave
0
 
LVL 13

Author Closing Comment

by:Shanan212
Comment Utility
Although the code I pasted worked, this worked as well!

I have saved both for future reference :)

Thanks all!

Sub CopyFunction()
    Dim lEndRow As Long, lStartRow As Long
    Dim num1 As Integer, num2 As Integer
    Dim wkb As Workbook
    Dim pivotSht As Worksheet, Finals As Worksheet, srcWks As Worksheet, wssheet As Worksheet
    Dim copyRng As Range, pasteRng As Range
      
    Set wssheet = Sheets("Payroll Summary")

    If Not wssheet Is Nothing Then
        Application.DisplayAlerts = False
        Worksheets("Payroll Summary").Delete
        Application.DisplayAlerts = True
    End If
      
    Set wkb = ThisWorkbook
    Set pivotSht = wkb.Sheets("Pivots")
         
    'put error checking in, to ensure sheet "Payroll Summary" doesn't already exist, or you'll get an error when you set the name to the new sheet
    Set Finals = wkb.Worksheets.Add(after:=wkb.Sheets(wkb.Sheets.Count))
    Finals.Name = "Payroll Summary"
      
    Finals.Range("A1:C1") = Split("ID,Sum of Debt,Sum of Credit", ",")
      
    '1st row starts from 3
    lStartRow = 3
      
    'last row = grand total and its not included
    lEndRow = (pivotSht.Range("A" & pivotSht.Rows.Count).End(xlUp).Row) - 1
      
    Set copyRng = pivotSht.Range("A" & lStartRow, pivotSht.Range("C" & lEndRow))
    Set pasteRng = Finals.Range("A2")
      
    'copy values only, not formats
    pasteRng.Resize(copyRng.Rows.Count, copyRng.Columns.Count).Value = copyRng.Value
      
    Finals.Columns.AutoFit
      
End Sub

Open in new window

0
 
LVL 85

Expert Comment

by:Rory Archibald
Comment Utility
Just as an FYI, the PivotTable object exposes various ranges you can refer to directly:

Sub CopyFunction()
   Dim lEndRow As Long, lStartRow As Long
   Dim num1 As Integer, num2 As Integer
   Dim wkb               As Workbook
   Dim pivotSht As Worksheet, Finals As Worksheet, srcWks As Worksheet, wssheet As Worksheet
   Dim copyRng As Range, pasteRng As Range
   Dim PT                As PivotTable

   Set wssheet = Sheets("Payroll Summary")

   If Not wssheet Is Nothing Then
      Application.DisplayAlerts = False
      Worksheets("Payroll Summary").Delete
      Application.DisplayAlerts = True
   End If

   Set wkb = ThisWorkbook
   Set pivotSht = wkb.Sheets("Pivots")

   'put error checking in, to ensure sheet "Payroll Summary" doesn't already exist, or you'll get an error when you set the name to the new sheet
   Set Finals = wkb.Worksheets.Add(after:=wkb.Sheets(wkb.Sheets.Count))
   Finals.Name = "Payroll Summary"


   Set PT = pivotSht.PivotTables(1)

   Set pasteRng = Finals.Range("A1")
   PT.RowRange.Resize(, PT.TableRange2.Columns.Count).Copy
   'copy values only, not formats
   pasteRng.PasteSpecial xlPasteValues
   ' replace headers
   Finals.Range("A1:C1") = Split("ID,Sum of Debt,Sum of Credit", ",")

   Finals.Columns.AutoFit

End Sub

Open in new window


Regards,
Rory
0

Featured Post

Highfive + Dolby Voice = No More Audio Complaints!

Poor audio quality is one of the top reasons people don’t use video conferencing. Get the crispest, clearest audio powered by Dolby Voice in every meeting. Highfive and Dolby Voice deliver the best video conferencing and audio experience for every meeting and every room.

Join & Write a Comment

Introduction While answering a recent question (http:/Q_27311462.html), I created an alternative function to the Excel Concatenate() function that you might find useful.  I tested several solutions and share the results in this article as well as t…
This article will guide you to convert a grid from a picture into Excel format using Microsoft OneNote and no other 3rd party application.
The viewer will learn how to create two correlated normally distributed random variables in Excel, use a normal distribution to simulate the return on different levels of investment in each of the two funds over a period of ten years, and, create a …
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.

762 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

6 Experts available now in Live!

Get 1:1 Help Now