VBA to help copy and paste few columns from pivot table 2 another table within sheet

[Kartyk]

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]

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]

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]

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]

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]

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]

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]

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]

thanks a lot. Works fine now.
Cheers
K

[Kartyk]

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]

Kindly ignore. I have disabled Grand total.