Error: Subscript out of range is coming while using EnableMultiplePageItems

I am trying to change the items in pivot filter of pivot table using macro. But for that select multiple item should be enabled. For that i am using below macro:

Sub Test_Excel()

Test_Excel Macro

Dim Area
Dim Subsidiary
Dim SheetName
Dim index
Dim flag
Dim Subs

Application.EnableEvents = False
Application.ScreenUpdating = False
Application.WindowState = xlNormal
For index = 1 To 2
    Sheets("GeographyFilter").Select

    Area = Cells(index, "A").Value
    Region = Cells(index, "B").Value
    flag = Cells(index, "C").Value
    SheetName = Cells(index, "D").Value

    Sheets("A").Select

    For Each pt In ActiveSheet.PivotTables

        pt.CubeFields("[DimArea].[Region].[Region]").EnableMultiplePageItems _
            = True

        If (flag = 1) And (Area = "IND") Then
            pt.PivotFields( _
            "[DimArea].[Region].[Region]").VisibleItemsList = Array("[DimArea].[Region].&", "[DimArea].[Region].&[Rajasthan]", _
                                                                               "[DimArea].[Region].&", "[DimArea].[Region].&[MP]", _
                                                                                "[DimArea].[Region].&", "[DimArea].[Region].&[UP]")

        Else
            pt.PivotFields("[DimArea].[Subsidiary].[Subsidiary]").CurrentPageName = "[DimGeography].[Subsidiary].&[" + Region + "]"
        End If

    Next pt

    ChDir "D:"
    ActiveWorkbook.SaveAs Filename:= _
    "D:\Test_" & SheetName & ".xlsm" _
    , FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

Next

End Sub

But it is giving error:

Subscript out of Range.

Any idea what is the problem?