VBA script doesn't run

Hi,

I have a pretty stupid problem.

I am not that familiar with VBA scripts in Excel, and my problem is I have a Script which simply doesn't run. If I try to run the subs, I get a pop-up asking for a "Macro Name" ? The script debugs with no errors. I have made other scripts which runs without problems i the same workbook.

These are the subs:

Code:

---

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Not Intersect(Target, Application.Range("RegionFilterRange")) Is Nothing Then
        UpdatePivotFieldFromRange "RegionFilterRange", "Col0", "PivotTable1"
    End If
End Sub
 

Public Sub UpdatePivotFieldFromRange(RangeName As String, FieldName As String, PivotTableName As String)
    Dim rng As Range
    Set rng = Application.Range("RegionFilterRange")
    Dim pt As PivotTable
    Dim Sheet As Worksheet
    For Each Sheet In Application.ActiveWorkbook.Worksheets
        On Error Resume Next
        Set pt = Sheet.PivotTables("PivotTable1")
    Next
    If pt Is Nothing Then GoTo Ex
    On Error GoTo Ex
    pt.ManualUpdate = True
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Dim Field As PivotField
    Set Field = pt.PivotFields("Col0")
    Field.ClearAllFilters
    Field.EnableItemSelection = False
    SelectPivotItem Field, rng.Text
    pt.RefreshTable
    Ex:
    pt.ManualUpdate = False
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
 
 
Public Sub SelectPivotItem(Field As PivotField, ItemName As String)
    Dim Item As PivotItem
    For Each Item In Field.PivotItems
        Item.Visible = (Item.Caption = ItemName)
    Next
End Sub

---

Any ideas ?

Br,
Jakob

Which part does not run? Can you post an example workbook please?

-Dan

Hi Danfleetwood,

Nothing happens when I push "run sub" ? So I guess the short answer is: all !:(

I have now attached an example with the script.

Br,
Jakob

What should happen?

Your procedure signature should be

Code:

---

Private Sub Worksheet_Change(ByVal Target As Range)

---

not

Code:

---

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

---

as you have it in the sheet code module.

Purpose: the code enables me to enter an item name in the RegionFilterRange named range and use that value to filter my PivotTable.

Public Sub UpdatePivotFieldFromRange:
Update the Region PivotField object with the value of the cell ("RegionFilterRange") (yellow cell).

Private Sub Workbook_SheetChange:
Detect when the user has entered a value into the cell "RegionFilterRange".

Public Sub SelectPivotItem:
SelectPivotItem loops through all the items in the field and sets each one's Visible property to False except for the item specified by ItemName which is set to True. This ensures that only ItemName will be visible in the field.

br,
Jakob

Hi xld,

Great thanks. Now it works.
Now we are at it: Do you by any chance know how to make the cell value a "wildcard" ? in the script ?

br,
Jakob

Explain that a bit more Jakob.

The script works fine as long as I write the exact name of the region (fx.: "DK"). But would it be possible to just write "K" in the cell ("RegionFilterRange"), and filter/get all the regions containing "K". I.e. result: "DK","UK", etc.

This should do it (note, I have added an option to reset the filter by inputting '(All)'). You have to add the wildcard, like *K or D*.

Code:

---

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Application.Range("RegionFilterRange")) Is Nothing Then
        UpdatePivotFieldFromRange _
        "RegionFilterRange", "Region", "PivotTable2"
    End If
End Sub

Public Sub UpdatePivotFieldFromRange( _
    ByVal RangeName As String, _
    ByVal FieldName As String, _
    ByVal PivotTableName As String)
    Dim Sheet As Worksheet
    Dim pt As PivotTable
    Dim rng As Range
    Dim vecItems As Variant
    Set rng = Application.Range("RegionFilterRange")
    For Each Sheet In Application.ActiveWorkbook.Worksheets
        On Error Resume Next
        Set pt = Sheet.PivotTables("PivotTable2")
    Next
    On Error GoTo Ex
    If Not pt Is Nothing Then
        pt.ManualUpdate = True
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        Dim Field As PivotField
        Set Field = pt.PivotFields("Region")
        Field.ClearAllFilters
        Field.EnableItemSelection = False
        If rng.Text = "(All)" Then
            Call ResetAllItems(pt, "Region")
        Else
            vecItems = GetItems(Worksheets("Sheet1").Range("A2:A20"), rng.Text)
            Call SelectPivotItem(Field, vecItems)
        End If
        pt.RefreshTable
    End If
    Ex:
    pt.ManualUpdate = False
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Private Function GetItems( ByVal LookupList As Range, ByVal LookupValue As Variant) As Variant
    Dim vecItems As Variant
    Dim cell As Range
    Dim cntItems As Long
    ReDim vecItems(1 To Application.CountA(LookupList))
    For Each cell In LookupList.Cells
        If cell.Text Like LookupValue Then
            cntItems = cntItems + 1
            vecItems(cntItems) = cell.Text
        End If
    Next cell
    ReDim Preserve vecItems(1 To cntItems)
    GetItems = vecItems
End Function

Private Function ResetAllItems( _
    ByRef pt As PivotTable, _
    ByVal ItemName As String) As Boolean
    Dim Item As PivotItem
    With pt
        For Each Item In .PivotFields(ItemName).PivotItems
            Item.Visible = True
        Next Item
    End With
End Function

Private Sub SelectPivotItem(Field As PivotField, ItemNames As Variant)
    Dim Item As PivotItem
    For Each Item In Field.PivotItems
        Item.Visible = Not (IsError(Application.Match(Item.Caption, ItemNames, 0)))
    Next
End Sub

---

xld.....you are the best !!!!!

This is perfect. thanks!

Br,
Jakob

Do you have Excel 2010 Jakob? If so, you could add slicers.