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
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 :/
Option ExplicitSub TextBox2_Click() CopyFunctionEnd SubSub 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.AutoFitEnd Sub
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.AutoFitEnd Function
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
ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.
One of a set of tools we're offering as a way to say thank you for being a part of the community.
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.AutoFitEnd Function
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
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.
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.AutoFitEnd Sub
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.AutoFitEnd Sub
Here's your code.
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