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
Code: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
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
Code: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
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.
Code: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
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.
Code: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
thanks a lot. Works fine now.
Cheers
K
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
Kindly ignore. I have disabled Grand total.