PDA

View Full Version : VBA to help copy and paste few columns from pivot table 2 another table within sheet



Kartyk
09-23-2016, 08:03 AM
Hi all,

I am looking for a code to allow copy paste of columns containing date and numbers. Criteria is that table should get populated based on pivot.
If date is repeated the code should not add new row but add numbers to already existing row with the date. Attached excel for reference. Color red indicates action.



Cheers
K

mana
09-23-2016, 05:24 PM
Option Explicit


Sub test()
Dim pvc As PivotCache
Dim pvt As PivotTable
Dim r As Range
Dim r2 As Range


Set r = Range("a1").CurrentRegion
Set r2 = r(1).Offset(, r.Columns.Count + 2)
r2.CurrentRegion.Clear

Set pvc = ActiveWorkbook.PivotCaches.Create(xlDatabase, r)
Set pvt = pvc.CreatePivotTable(r2)

With pvt
.RowAxisLayout xlTabularRow
.ColumnGrand = False
.RowGrand = False

.PivotFields("Date").Orientation = xlRowField

.AddDataField .PivotFields("Met"), , xlSum
.AddDataField .PivotFields("Not Met"), , xlSum
.AddDataField .PivotFields("Total"), , xlSum
End With

End Sub


Sub test2()
Dim r As Range
Dim r2 As Range


Set r = Range("a1").CurrentRegion
Set r2 = r(1).Offset(, r.Columns.Count + 2)


With r2
.CurrentRegion.ClearContents
r.Rows(1).Copy .Cells(1)

.Consolidate _
Sources:=r.Address(ReferenceStyle:=xlR1C1, External:=True), _
Function:=xlSum, _
TopRow:=True, _
LeftColumn:=True

.CurrentRegion.Columns(1).NumberFormat = r.Cells(2, 1).NumberFormat
End With

End Sub

Kartyk
09-26-2016, 12:45 AM
Hi Mana,

Thanks for your response. However, not sure if thhe code does what it is supposed to do. Could you please review once and confiirm.

Cheers
K

mana
09-26-2016, 05:15 AM
Option Explicit

Sub test3()
Dim src1 As Range
Dim src2 As Range
Dim dst As Range
Dim adr1 As String
Dim adr2 As String

Set src1 = Range("a1").CurrentRegion
Set src2 = Range("a11").CurrentRegion
Set dst = Range("h1")


adr1 = src1.Address(ReferenceStyle:=xlR1C1, External:=True)
adr2 = src2.Address(ReferenceStyle:=xlR1C1, External:=True)


With dst
.CurrentRegion.Clear
src1.Rows(1).Copy .Cells(1)

.Consolidate _
Sources:=Array(adr1, adr2), _
Function:=xlSum, _
TopRow:=True, _
LeftColumn:=True

.CurrentRegion.Columns(1).NumberFormat = src1.Cells(2, 1).NumberFormat
End With

End Sub

Kartyk
09-26-2016, 05:27 AM
HI Mana,

The requirement is left table should update the table on the right. Key here is the date. If the date matches the numbers should add onto existing numbers against the date. If its a new date then a new row should be added.

Hope it is clear.

mana
09-26-2016, 06:18 AM
Option Explicit

Sub test4()
Dim src As Range
Dim tmp As Range
Dim dst As Range
Dim adr1 As String
Dim adr2 As String

Set src = Range("a1").CurrentRegion
Set dst = Range("h1")
Set tmp = Range("z1")

dst.CurrentRegion.Copy tmp

adr1 = src.Address(ReferenceStyle:=xlR1C1, External:=True)
adr2 = tmp.CurrentRegion.Address(ReferenceStyle:=xlR1C1, External:=True)

dst.CurrentRegion.Clear
src.Rows(1).Copy dst

dst.Consolidate _
Sources:=Array(adr1, adr2), _
Function:=xlSum, _
TopRow:=True, _
LeftColumn:=True

dst.CurrentRegion.Columns(1).NumberFormat = _
src.Cells(2, 1).NumberFormat

dst.CurrentRegion.Sort Key1:=dst, Header:=xlYes
tmp.CurrentRegion.Clear

End Sub

Kartyk
09-26-2016, 07:00 AM
It still does not work the way it is intended to. All it takes is to copy a row and paste it elsewehre. But the only catch is date verification - If it exists - add numbers, else add new row and populate the numbers.

mana
09-26-2016, 03:45 PM
Option Explicit

Sub test5()
Dim src As Range
Dim tmp As Range
Dim dst As Range
Dim adr1 As String
Dim adr2 As String

Set src = Range("a1").CurrentRegion.Offset(1)
Set dst = Range("h1").CurrentRegion.Offset(1)
Set tmp = Range("z1")

dst.Copy tmp

adr1 = src.Address(ReferenceStyle:=xlR1C1, External:=True)
adr2 = tmp.CurrentRegion.Address(ReferenceStyle:=xlR1C1, External:=True)

dst.Clear
src.Rows(1).Copy dst(1)

dst(1).Consolidate _
Sources:=Array(adr1, adr2), _
Function:=xlSum, _
TopRow:=True, _
LeftColumn:=True

dst.Columns(1).NumberFormat = _
src(2, 1).NumberFormat

dst.Sort Key1:=dst, Header:=xlYes
tmp.CurrentRegion.Clear

End Sub

Kartyk
09-27-2016, 12:06 AM
thanks a lot. Works fine now.
Cheers
K

Kartyk
09-28-2016, 01:15 AM
I have a concerns. Source is a pivot table and I do not want the Grand total from pivot copied. Is there a way to avoid copying Grand total ?

Cheers

Kartyk
09-28-2016, 01:29 AM
Kindly ignore. I have disabled Grand total.