Automating Pivot Table using VBA,VBA Teacher Sourav,Kolkata 08910141720

Sub pivotvba()
 With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
    End With
For Each wks In Application.Worksheets
        If wks.Name = "Pivot_Table" Then wks.Delete
    Next

 cntsheets = Application.Sheets.Count
    Set NewSheet = Application.Worksheets.Add(After:=Worksheets(cntsheets))
    NewSheet.Name = "Pivot_Table"
   
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With
 Application.DisplayAlerts = True
  Dim pt As PivotTable
  Dim pc As PivotCache
  Dim pf As PivotField
  Dim pi As PivotItem

'set the pivotcache
Sheets("Data").Select
Set pc = ActiveWorkbook.PivotCaches.Create(xlDatabase, Sheets("Data").Range("A3").CurrentRegion)

'create the pivot table
Sheets("Pivot_Table").Select
Set pt = ActiveSheet.PivotTables.Add(pc, Range("A3"), "Pivot_Table_1")

'put the fields

With pt
'.PivotFields("Salesperson").Orientation = xlColumnField
.PivotFields("Category").Orientation = xlRowField
.PivotFields("Salesperson").Orientation = xlColumnField
.PivotFields("Revenue").Orientation = xlDataField
'set the number format

.DataBodyRange.NumberFormat = "$#,##0.00"

'classic view

.InGridDropZones = True


'switch back from classic view
.InGridDropZones = False

'add calculated field

.CalculatedFields.Add "Eligible for bonus", "= IF(Revenue >1500,1,0)", True
.PivotFields("Eligible for bonus").Orientation = xlDataField
'Changing the caption of the calculated field,removing the sum of part
.DataPivotField.PivotItems("Sum of Eligible for bonus").Caption = "Eligible for bonus ? "

'changing the number format of the callculated field so that it becomes only 1 and 0

.PivotFields("Eligible for bonus ? ").NumberFormat = "#,##0"
'converting 1 and 0 to yes and no

.PivotFields("Eligible for bonus ? ").NumberFormat = """Yes"";;""No"""

'Add region column as report filter
.PivotFields("Region").Orientation = xlPageField


End With
'Setting default filter

Set pf = pt.PivotFields("Region")
With pf
   For Each pi In pf.PivotItems
   If pi.Name = "East" Then
   pi.Visible = True
   Else
   pi.Visible = False
   End If
  
   Next pi
 End With

'setting filter in a more customized way,suppose
'we want to see revenue generated by eastern region with
'the category beverages,we already filtered the data by east
'now let us filter the filtered table by a cirtain category

Set pf = pt.PivotFields("Category")
With pf
   For Each pi In pf.PivotItems
   If pi.Name = "Beverages" Then
   pi.Visible = True
   Else
   pi.Visible = False
   End If
  
   Next pi
 End With

'Suppose we want to filter column by both east and west

Set pf = pt.PivotFields("Region")
With pf
   For Each pi In pf.PivotItems
   If pi.Name = "East" Or pi.Name = "West" Then
   pi.Visible = True
   Else
   pi.Visible = False
   End If
  
   Next pi
 End With
'Suppose we want to filter the row by both beverages and candy
Set pf = pt.PivotFields("Category")
With pf
   For Each pi In pf.PivotItems
   If pi.Name = "Beverages" Or pi.Name = "Candy" Then
   pi.Visible = True
   Else
   pi.Visible = False
   End If
  
   Next pi
 End With

'Update the pivot table

ThisWorkbook.RefreshAll
End Sub

Arrays in VBA

Sub DeclaringArrays()

'Declare Array with range 0,1,2,3

Dim MyArray(0 To 3) As Variant

'Declare Array with range 0,1,2,3

Dim MyArray(3) As Variant

'Declare Array with range 1,2,3

Dim MyArray(1 To 3) As Variant

'Declare Array with range 2,3,4

Dim MyArray(2 To 4) As Variant

'DYNAMIC ARRAYS

'Declare Array with Dynamic Range

Dim MyArray() As Variant

'Resize Array with range 0,1,2,3,4

ReDim MyArray(0 To 4)

'ASSIGN VALUES TO AN ARRAY

MyArray(0) = 100

MyArray(1) = 200

MyArray(2) = 300

MyArray(3) = 400

MyArray(4) = 500

MyArray(5) = 600 '<<< Will Return an error because there is not 5th element.

'LOOP THROUGH ARRAYS

'Using For Loop

Dim i As Long

For i = LBound(MyArray) To UBound(MyArray)

Debug.Print MyArray(i)

Next

'Using For Each Loop

Dim Elem As Variant

For Each Elem In MyArray

Debug.Print Elem

Next

'USE ERASE

'Declare Static Array

Dim MyArray(0 To 3) As Long

Erase MyArray '<<< All Values will be set to 0.

'Declare Dynamic Array

Dim MyArray() As Long

ReDim MyArray(0 To 3)

Erase MyArray '<<< Array is erased from memory.

'USE REDIM

Dim MyArray() As Variant

MyArray(0) = "MyFirstElement"

'Old Array with "MyFirstElement" is now deleted.

ReDim MyArray(0 To 4)

Dim MyArray() As Variant

MyArray(0) = "MyFirstElement"

'Old Array with "MyFirstElement" is now Resized With Original Content Kept in Place.

ReDim Preserve MyArray(0 To 4)

'USING MULTIDIMENSIONAL ARRAYS

'Declare two dimensional array

Dim MultiDimArray(0 To 3, 0 To 3) As Integer

Dim i, j As Integer

'Assign values to array

For i = LBound(MultiDimArray, 1) To UBound(MultiDimArray, 1)

For j = LBound(MultiDimArray, 2) To UBound(MultiDimArray, 2)

MultiDimArray(i, j) = i + j

Next j

Next i

'Print values from array.

For i = LBound(MultiDimArray, 1) To UBound(MultiDimArray, 1)

For j = LBound(MultiDimArray, 2) To UBound(MultiDimArray, 2)

Debug.Print MultiDimArray(i, j)

Next j

Next i

End Sub

Attribute VB_Name = "Arrays"

Offset in VBA

Sub OffsetActiveCell()

'Go 5 rows below & 4 columns to the left

ActiveCell.Offset(5, -4).Select

'Go 2 rows above & 3 columns to the right

ActiveCell.Offset(-2, 3).Select

'Error occurs if the row you're selecting is off the sheet.

End Sub

Sub OffsetCell()

'Go 5 rows below & 4 columns to the right

ActiveSheet.Cells(7, 3).Offset(5, 4).Select

'Go 5 rows below & 4 columns to the right

ActiveSheet.Range("C7").Offset(5, 4).Select

End Sub

Sub OffsetRangeOfCell()

'Go 4 rows below & 3 columns to the right - MAINTAING THE SAME RANGE SIZE

ActiveSheet.Range("Test").Offset(4, 3).Select

'Long handed way

'Go 4 rows below & 3 columns to the right - MAINTAING THE SAME RANGE SIZE

Sheets("Sheet2").Activate

ActiveSheet.Range("Test").Offset(4, 3).Select

End Sub

Sub ResizeSelection()

'Select the range

Range("Test").Select

'Resize the selection by five rows

Selection.Resize(Selection.Rows.Count + 5, Selection.Columns.Count).Select

End Sub

Sub ResizeSelectionOffset()

'Select the range

Range("Test").Select

'Offset and then resize the selection by five rows

Selection.Offset(4, 3).Resize(Selection.Rows.Count + 5, Selection.Columns.Count).Select

End Sub

Sub SelectUnionOfTwoOrMoreRanges()

Application.Union(Range("Test"), Range("Sample")).Select

'DOES NOT WORK ACROSS SHEETS

Set y = Application.Union(Range("Sheet1!A1:B2"), Range("Sheet1!C3:D4"))

Set y = Application.Union(Range("Sheet1!A1:B2"), Range("Sheet2!C3:D4"))

End Sub

Sub SelectIntersection()

'DOES NOT WORK ACROSS SHEETS

Application.Intersect(Range("Test"), Range("Sample")).Select

End Sub

Attribute VB_Name = "Offset"