pivot table vba help

Option Explicit
Option Base 0

Sub VolumeTable()

    Const SourceSheet As String = "pivot test"
    Const PivotName As String = "Lot Report"
    Const TargetCell As String = "A1"
    
    ' Add more columns as required.
    ' Keep "Brkr Name" in first position.
    Const ColumnCaptions As String = "Exchange,Date,Quantity"
    
    Dim WsS As Worksheet                ' Source
    Dim WsT As Worksheet                ' Target (Pivot)
    Dim Prng As Range
    Dim Pcach As PivotCache
    Dim Ptbl As PivotTable
    Dim Pfld As PivotField
    Dim Caps() As String                ' Array(ColumnCaptions)
    Dim i As Long
    
    Caps = Split(ColumnCaptions, ",")
    With ThisWorkbook
        Set WsS = .Worksheets(SourceSheet)
        If Not ColumnsExist(Caps, Prng, WsS) Then Exit Sub
        
        Set Prng = Prng.CurrentRegion
        Set Prng = Prng.Resize(Prng.Rows.Count - 1)
        Set WsT = GetSheet(PivotName)
        Set Pcach = .PivotCaches.Create( _
                     SourceType:=xlDatabase, _
                     SourceData:=FullRangeName(Prng), _
                     Version:=xlPivotTableVersion12)
    End With
    Set Ptbl = Pcach.CreatePivotTable( _
                     TableDestination:=FullRangeName(WsT.Range(TargetCell)), _
                     TableName:=PivotName, _
                     DefaultVersion:=xlPivotTableVersion12)
    
    i = LBound(Caps)
    With Ptbl.PivotFields(Caps(i))
        .Orientation = xlRowField
        .Position = 1
    End With
        
    For i = i + 1 To UBound(Caps)
        Set Pfld = Ptbl.AddDataField(Ptbl.PivotFields(Caps(i)))
        With Pfld
            .Caption = "_" & Caps(i)
            .Function = xlSum
        End With
    Next i
    
    With WsT
        .Range(TargetCell).Value = Caps(0) & "s"
        .Columns.AutoFit
    End With
    ThisWorkbook.ShowPivotTableFieldList = False
End Sub

Private Function ColumnsExist(Caps() As String, _
                              StartCell As Range, _
                              WsS As Worksheet) As Boolean
    Dim i As Long
    
    For i = UBound(Caps) To LBound(Caps) Step -1
        Caps(i) = Trim(Caps(i))
        Set StartCell = WsS.Cells.Find(Caps(i))
        If StartCell Is Nothing Then
            MsgBox "Column '" & Caps(i) & "' doesn't exist" & vbCr & _
                   "in worksheet '" & WsS.Name & "'." & vbCr & _
                   "Sorry, I can't continue.", _
                   vbCritical, "Fatal source data error"
        End If
    Next i
    ColumnsExist = True
End Function

Private Function GetSheet(ByVal Sn As String) As Worksheet

    Dim Idx As Long
    
    DelSheet Sn
    With ThisWorkbook
        Set GetSheet = .Worksheets.Add(After:=.Sheets(.Sheets.Count))
        ActiveSheet.Name = Sn
    End With
End Function

Private Sub DelSheet(ByVal Sn As String)

        On Error Resume Next
        Application.DisplayAlerts = False
        ThisWorkbook.Worksheets(Sn).Delete
        Application.DisplayAlerts = True
End Sub

Private Function FullRangeName(rng As Range) As String
    
    Dim Ln As String
    
    With rng
        Ln = .Parent.Name
        If InStr(Ln, " ") Then Ln = "'" & Ln & "'"
        FullRangeName = Ln & "!" & Application.ConvertFormula( _
                                   Formula:=.Address, _
                                   FromReferenceStyle:=xlA1, _
                                   ToReferenceStyle:=xlR1C1)
    End With
End Function

Select allOpen in new window