VBA script doesn't run

[JayJay6]

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:

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

[danfleetwood]

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

-Dan

[JayJay6]

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

[danfleetwood]

What should happen?

[Bob Phillips]

Your procedure signature should be

Private Sub Worksheet_Change(ByVal Target As Range)


not

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

as you have it in the sheet code module.

[JayJay6]

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

[JayJay6]

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

[Bob Phillips]

Explain that a bit more Jakob.

[JayJay6]

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.

[Bob Phillips]

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*.



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

[JayJay6]

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

This is perfect. thanks!

Br,
Jakob

[Bob Phillips]

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