Problem Creating Pivot Table with VBA

[MWeber2222]

Hi,

I am working on a macro to:

1. Combine all data from multiple sheets
2. Eliminate unnecessary columns
3. Create a new sheet named "Pivot Table" at the front of the workbook
4. Insert the Pivot Table on the created sheet and
   • Add CBC as a Row Label
   • Count the number of occurrences of each CBC value

I have gotten everything to work up to step #4. I tried recording the steps but it does not work. Any help with step 4 would be greatly appreciated. The code I have tried so far is below:

Sub SingleSheet()

'Combine all data onto single sheet
    ScreenUpdating = False
    Dim J As Integer
    On Error Resume Next
    Sheets(1).Select
    Worksheets.Add
    Sheets(1).Name = "Combined"
    Sheets(2).Activate
    Range("A1").EntireRow.Select
    Selection.Copy Destination:=Sheets(1).Range("A1")
    For J = 2 To Sheets.Count
    Sheets(J).Activate
    Range("A1").Select
    Selection.CurrentRegion.Select
    Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
    Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
    Next

'Delete non-essential columns, name headers
    Sheets("Combined").Select
    Range("A:A,D:D,E:E,F:F").Select
    Range("F1").Activate
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "CBC"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "DEVICE MGR"
    Cells.Select
    Cells.EntireColumn.AutoFit
  
'Make into Table
    Columns("A:B").Select
    ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A:$B"), , xlYes).Name = _
        "Table1"
    Columns("A:B").Select
    Application.Goto Reference:="Table1"

  
'Create Sheet for Pivot Table
    Sheets(1).Select
    Worksheets.Add
    Sheets(1).Name = "Pivot Table"
  
'Insert Pivot Table for CBC Count
    Range("Table1").Select
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "Table1", Version:=xlPivotTableVersion14).CreatePivotTable TableDestination _
        :="Pivot Table!R1C1", TableName:="PivotTable9", DefaultVersion:= _
        xlPivotTableVersion14
    Sheets("Pivot Table").Select
    Cells(1, 1).Select
    With ActiveSheet.PivotTables("PivotTable9").PivotFields("CBC")
        .Orientation = xlRowField
        .Position = 1
    End With
    ActiveSheet.PivotTables("PivotTable9").AddDataField ActiveSheet.PivotTables( _
        "PivotTable9").PivotFields("CBC"), "Count of CBC", xlCount

  
End Sub

__________________________________



Thanks!
MW

 

[Luke M]

you were giving the destination of the new pivot table as a string, and it needed to be a range. Error was hiding because you had put "On Error Resume Next" at beginning of macro. Try this:

Sub SingleSheet()

'Combine all data onto single sheet
Application.ScreenUpdating = False
Dim J As Integer
Dim startWS As Worksheet
Dim combWS As Worksheet
Dim ptWS As Worksheet
Dim rngCopy As Range

Set startWS = ActiveSheet
Set combWS = Worksheets.Add(before:=Sheets(1))
combWS.Name = "Combined"

startWS.Range("1:1").Copy combWS.Range("A1")

For J = 2 To Sheets.Count
    Set rngCopy = Sheets(J).Range("A1").CurrentRegion
    Set rngCopy = rngCopy.Offset(1).Resize(rngCopy.Rows.Count - 1)
    rngCopy.Copy combWS.Range("A65536").End(xlUp).Offset(2)
Next

'Delete non-essential columns, name headers
With combWS
    .Range("A:A,D:D,E:E,F:F").Delete Shift:=xlToLeft
    .Range("A1").Value = "CBC"
    .Range("B1").Value = "DEVICE MGR"
    .Cells.EntireColumn.AutoFit


    'Make into Table
    .ListObjects.Add(xlSrcRange, .Range("A:B"), , xlYes).Name = "Table1"
End With


'Create Sheet for Pivot Table
Set ptWS = Worksheets.Add(before:=Sheets(1))
ptWS.Name = "Pivot Table"

'Insert Pivot Table for CBC Count
ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
    "Table1", Version:=xlPivotTableVersion14).CreatePivotTable TableDestination:=ptWS.Cells(1), TableName:="Pivot1"


With ptWS.PivotTables(1)
    With .PivotFields("CBC")
        .Orientation = xlRowField
        .Position = 1
    End With
    .AddDataField .PivotFields("CBC"), "Count of CBC", xlCount
End With
Application.ScreenUpdating = True
End Sub

 

[MWeber2222]

Luke,

That did the trick. I appreciate your assistance. Thank you!

-MW

you were giving the destination of the new pivot table as a string, and it needed to be a range. Error was hiding because you had put "On Error Resume Next" at beginning of macro. Try this:

Sub SingleSheet()

'Combine all data onto single sheet
Application.ScreenUpdating = False
Dim J As Integer
Dim startWS As Worksheet
Dim combWS As Worksheet
Dim ptWS As Worksheet
Dim rngCopy As Range

Set startWS = ActiveSheet
Set combWS = Worksheets.Add(before:=Sheets(1))
combWS.Name = "Combined"

startWS.Range("1:1").Copy combWS.Range("A1")

For J = 2 To Sheets.Count
    Set rngCopy = Sheets(J).Range("A1").CurrentRegion
    Set rngCopy = rngCopy.Offset(1).Resize(rngCopy.Rows.Count - 1)
    rngCopy.Copy combWS.Range("A65536").End(xlUp).Offset(2)
Next

'Delete non-essential columns, name headers
With combWS
    .Range("A:A,D:D,E:E,F:F").Delete Shift:=xlToLeft
    .Range("A1").Value = "CBC"
    .Range("B1").Value = "DEVICE MGR"
    .Cells.EntireColumn.AutoFit


    'Make into Table
    .ListObjects.Add(xlSrcRange, .Range("A:B"), , xlYes).Name = "Table1"
End With


'Create Sheet for Pivot Table
Set ptWS = Worksheets.Add(before:=Sheets(1))
ptWS.Name = "Pivot Table"

'Insert Pivot Table for CBC Count
ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
    "Table1", Version:=xlPivotTableVersion14).CreatePivotTable TableDestination:=ptWS.Cells(1), TableName:="Pivot1"


With ptWS.PivotTables(1)
    With .PivotFields("CBC")
        .Orientation = xlRowField
        .Position = 1
    End With
    .AddDataField .PivotFields("CBC"), "Count of CBC", xlCount
End With
Application.ScreenUpdating = True
End Sub