ExcelBanter - pivot tables criteria vba

Nick,

Here is a macro I wrote which creates a pivot table from Excel data.
Currently, it has 3 row fields, 1 column field, and 1 data field. I tweaked
it to read the field names from cells A5 - E5 (using the contents of those
cells as criteria for the pivot table.) Also, as written, it takes data from
Sheet1 and creates the pivot table on a new sheet Test1.

Sub MakePvtTbl()
'Creates a pivot table from outstanding records. !!! ACTIVECELL MUST BE
ANY CELL IN THE DATA !!!
Dim Sorce As Range, Dest As Range, msg5 As String, strFld As String
Const PvtTbl = "Test1"
On Error GoTo MPTerr5
'Select all the cells with data as the source (Sorce object) for the pivot
table.
ActiveCell.CurrentRegion.Select
Set Sorce = Selection
'Delete the existing PvtTbl sheet, then create a new one.
On Error Resume Next
Application.DisplayAlerts = False
ActiveWorkbook.Sheets(PvtTbl$).Delete
Application.DisplayAlerts = True
Worksheets.Add.Move Befo=Sheet1
ActiveSheet.Name = PvtTbl$
On Error GoTo MPTerr5
'Set the object Dest to be cell A3 on the new sheet. That's where the pivot
table will be created.
Set Dest = ActiveSheet.Range("A3")
On Error GoTo MPTerr5
'Call the PivotTableWizard
ActiveSheet.PivotTableWizard SourceType:=xlDatabase, SourceData:=Sorce,
TableDestination:=Dest, TableName:="PivotTable1"
'Define the row fields.
strFld$ = ActiveWorkbook.Sheets("Sheet1").Range("C5").Value
With ActiveSheet.PivotTables("PivotTable1").PivotFields (strFld$)
.Orientation = xlRowField
.Position = 1
End With
strFld$ = ActiveWorkbook.Sheets("Sheet1").Range("A5").Value
With ActiveSheet.PivotTables("PivotTable1").PivotFields (strFld$)
.Orientation = xlRowField
.Position = 2
End With
strFld$ = ActiveWorkbook.Sheets("Sheet1").Range("B5").Value
With ActiveSheet.PivotTables("PivotTable1").PivotFields (strFld$)
.Orientation = xlRowField
.Position = 3
End With
'Define the column field.
strFld$ = ActiveWorkbook.Sheets("Sheet1").Range("D5").Value
With ActiveSheet.PivotTables("PivotTable1").PivotFields (strFld$)
.Orientation = xlColumnField
.Position = 1
End With
'Define the data field.
strFld$ = ActiveWorkbook.Sheets("Sheet1").Range("E5").Value
With ActiveSheet.PivotTables("PivotTable1").PivotFields (strFld$)
.Orientation = xlDataField
.Position = 1
End With
ActiveSheet.Range("A3").Select
Cleanup5:
Set Sorce = Nothing
Set Dest = Nothing
Exit Sub
MPTerr5:
If Err.Number < 0 Then
msg5$ = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
MsgBox msg5$, , "MakePvtTbl error", Err.HelpFile, Err.HelpContext
End If
GoTo Cleanup5
End Sub

I hope this is helpful.

Hutch
------------------------------------------------------
"cherrynich" wrote:

I need to use vba to make a pivot table's criteria equal the contents of a
cell. Any code/help would be very much appreciated.

Thank you,
Nick Cherry