Logo 
Search:

MS Office Answers

Ask Question   UnAnswered
Home » Forum » MS Office       RSS Feeds
  Question Asked By: Harry Hunter   on Sep 12 In MS Office Category.

  
Question Answered By: Audris Schmidt   on Sep 12

The macro  & function below should meet your needs. Copy & paste the code below
into a code module in a new workbook. Send this workbook to each of your
managers with instructions to enter his/her employees on Sheet1 in column A
starting in row 1.

To run the macro:
1. Have the macro workbook open.
2. Open the pivot  table workbook. Click any cell in the table.
3. select  Macro >> Macros from the Tools menu, or press {Alt}{F8}, to display
list  of all available macros. Run the macro SelectNames.

Option Base 1

Public Sub SelectNames()
'Select names  from a list for display in a pivot table.
'ACTIVECELL MUST BE ANY CELL WITHIN THE PIVOT TABLE.
Dim Namez() As String, NameCnt As Long
Dim msg1 As String, x As Long, y As Long, FoundIt As Boolean
Dim StartWB As Workbook, StartSht As Worksheet, StartCell As Range
On Error GoTo SNerr1
Set StartWB = ActiveWorkbook
Set StartCell = ActiveCell
Set StartSht = ActiveSheet
'If the active cell is not in a pivot table, tell user & quit.
If IsPivotTable(ActiveCell) = False Then
MsgBox "You must select a cell in the pivot table  before running  the
macro", _
vbExclamation, "SelectNames error"
GoTo Cleanup1
End If
Application.ScreenUpdating = False
'Read the list of names from Sheet1 in this workbook.
ThisWorkbook.Activate
Sheets("Sheet1").Activate
Range("A1").Activate
NameCnt& = 0
Do While Len(ActiveCell.Value) > 0
NameCnt& = NameCnt& + 1
ReDim Preserve Namez(NameCnt&)
Namez(NameCnt&) = ActiveCell.Value
ActiveCell.Offset(1, 0).Activate
Loop
'Return to the starting workbook/sheet/cell.
StartWB.Activate
StartSht.Activate
StartCell.Activate
'Cycle through all pivotitems in the Name fields for this pivot table. Check
each one against Namez().
'If in Namez(), set visible to TRUE; if not, set to FALSE.
With ActiveSheet.PivotTables(ActiveCell.PivotTable.Name)
For x& = 1 To .PivotFields("Name").PivotItems.Count
FoundIt = False
For y& = 1 To NameCnt&
If .PivotFields("Name").PivotItems(x&).Value = Namez(y&) Then
FoundIt = True
Exit For
End If
Next y&
If FoundIt = True Then
.PivotFields("Name").PivotItems(x&).Visible = True
Else
.PivotFields("Name").PivotItems(x&).Visible = False
End If
Next x&
End With
Cleanup1:
Set StartWB = Nothing
Set StartSht = Nothing
Set StartCell = Nothing
Application.ScreenUpdating = True
Exit Sub
SNerr1:
If Err.Number <> 0 Then
msg1$ = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
MsgBox msg1$, , "SelectNames error", Err.HelpFile, Err.HelpContext
End If
GoTo Cleanup1
End Sub

Private Function IsPivotTable(InCell As Range) As Boolean
On Error GoTo IPTerr1
'Try to select the RowRange of the pivot table which contains InCell. If
successful,
'reactivate InCell and return TRUE.
ActiveCell.PivotTable.RowRange.Select
InCell.Activate
ActiveCell.Select
IsPivotTable = True
Exit Function
IPTerr1:
'If can't select the RowRange, return FALSE (not a pivot table).
IsPivotTable = False
End Function

Share: 

 
 
Didn't find what you were looking for? Find more on Excel Pivot Table Drop Down Macro Or get search suggestion and latest updates.


Tagged: