pivot table single column
 

Hi all,
just a little sub to manage single columns in a pivot table, since I did
not find, if existing, the correspondent object. Is possible to do the
same in an easier way? thank, t.s.
p.s. I'm sorry, but variables and comments are in italian, while some
labels refer to a specific pivot table

Sub tabella_pivot()
'dichiarazione variabili
Dim dati As Range
Dim prima_cella As Range
Dim ultima_cella As Range
Dim colonna As Range
Dim totale_righe As Integer
Dim contatore As Integer
Dim risultati As Range
Dim cella_risultati As Range
Dim etichette_anni As Range

'fa pulizia della precedente estrazione
ActiveSheet.Range("r1:z4").ClearContents
'stabilisce la cella dove scrivere i risultati
Set cella_risultati = Range("r2")
'individua le etichette di approval
Set etichette_anni =
ActiveSheet.PivotTables("outdegree").PivotFields(" approval").DataRange
'individua i dati, finalmente...sembra non esista l'oggetto colonna
dati...mah
ActiveSheet.PivotTables("outdegree").PivotSelect "", xlDataOnly
'imposta la variabile dati sulla selezione
Set dati = Selection
' si rende conto delle dimensioni della matrice di dati
totale_righe = dati.Rows.Count
totale_colonne = dati.Columns.Count
'frulla i dati, colonna dopo colonna
For contatore = 1 To totale_colonne
Set prima_cella = dati.Cells(1, contatore)
Set ultima_cella = dati.Cells(totale_righe, contatore)
Set colonna = ActiveSheet.Range(prima_cella, ultima_cella)
'scrive i risultati
cella_risultati.Offset(0, contatore - 1) =
Application.WorksheetFunction.Average(colonna)
cella_risultati.Offset(1, contatore - 1) =
Application.WorksheetFunction.VarP(colonna)
cella_risultati.Offset(2, contatore - 1) =
Application.WorksheetFunction.VarP(colonna) /
Application.WorksheetFunction.Average(colonna)
Next contatore
'copia le intestazioni di approval; non è detto che per ogni estrazione
ci siano tutti gli anni!
etichette_anni.Select
Selection.Copy
cella_risultati.Offset(-1, 0).Select
ActiveSheet.Paste
' that's all folks! test it please
End Sub

*** Sent via Developersdex http://www.developersdex.com ***
Don't just participate in USENET...get rewarded for it!