Substitute string in pivot tables

 

Download as .sbs Shows as plain text

 

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
'For all selected pivot tables of the current output navigator,
'this program substitutes the strings contained in the
'Orig() array with the respective strings contained into the
'Subst() array.
'That is, the string contained in Orig(1), Orig(2),... will be
'substituted respectively with the strings contained in
'Subst(1), Subst(2),...
'Limitation: table's title and footnotes will be not modified.

'Ray's note: Fabrizio's script could be modified to apply to ALL pivot tables in the
'Output by changing the Line
'                If .SPSSType=SPSSPivot And .Selected Then
'To
'                If .SPSSType=SPSSPivot Then


Public Orig() As String, Subst() As String

Sub SetArrays
'Defines both Orig() and Subst() arrays.
'Here are defined 3 strings to be substituted
ReDim Orig (1 To 3) As String  'original string to be modified
ReDim Subst(1 To 3) As String  'substituting string

        Orig(1)="-$1"       :  Subst(1)="$0"
        Orig(2)="Female"       :  Subst(2)="Fem."
        Orig(3)="Std. Deviation":  Subst(3)="S.D."
End Sub

Sub Main
Dim objItems As ISpssItems, objPivot As PivotTable
Dim Selected() As Integer
Dim ItemIndex As Integer, NSelected As Integer

        'Continue the program only if there is at least one output document.
        If objSpssApp.Documents.OutputDocCount > 0 Then
           'Get the currently designated output document items collection.
           Set objItems = objSpssApp.GetDesignatedOutputDoc.Items
        Else
                MsgBox "No Navigator window exists"
                Exit Sub
        End If

    'Stores the selected pivot tables indexes
    NSelected=0
    For ItemIndex=0 To objItems.Count-1
        With objItems.GetItem(ItemIndex)
                If .SPSSType=SPSSPivot And .Selected Then
                        NSelected=NSelected+1
                        ReDim Preserve Selected(1 To NSelected) As Integer
                        Selected(NSelected)=ItemIndex
                End If
            End With
    Next ItemIndex

    If NSelected=0 Then
        MsgBox "No Pivot tables into the current Navigator window"
        Exit Sub
    End If

        'Fills the Orig and Subst arrays
        SetArrays

        'modify all pivot tables selected into the output navigator
    For ItemIndex=1 To NSelected
        With objItems.GetItem(Selected(ItemIndex))
                        Set objPivot=.ActivateTable
                        objPivot.UpdateScreen=False

                        'modifies all column labels cells
                        ModLabelsArrayCells objPivot.ColumnLabelArray

                        'modifies all row labels cells
                        ModLabelsArrayCells objPivot.RowLabelArray

                        objPivot.UpdateScreen=True
                        .Deactivate
                End With
        Next ItemIndex
End Sub

Sub ModLabelsArrayCells(ByVal objLabelArray As ISpssLabels)
'Modifies all valid cells of the label array
Dim Rows As Long, Cols As Long

        'scans all valid cells of table's label array
        With objLabelArray
                For Rows=0 To .NumRows-1
                        For Cols=0 To .NumColumns-1
                            'modify the cell's string if it isn't null
                            If Not IsNull(.ValueAt(Rows,Cols)) Then
                                If .ValueAt(Rows,Cols)<>"" Then     'assigns the new label
							    .ValueAt(Rows,Cols)=GetNewLabel(.ValueAt(Rows,Cols))
                                End If
                            End If
                        Next Cols
                Next Rows
        End With
End Sub

Function GetNewLabel(ByVal OldLabel As String) As String
'returns the label that substitutes the old label
Dim TextPos As Integer, StartPos As Integer, i As Integer
Dim ModLabel As String
        ModLabel=OldLabel
        StartPos=0
        For i=1 To UBound(Orig)
                Do
                        TextPos=InStr(StartPos,ModLabel,Orig(i))
                        If TextPos>0 Then
                                ModLabel=Left(ModLabel,TextPos-1)+Subst(i)+ Mid(ModLabel,TextPos+Len(Orig(i)),Len(ModLabel)-TextPos-Len(Orig(i))+1)
                                StartPos=TextPos+Len(Subst(i))-1
                        End If
                Loop Until TextPos=0
        Next i
        GetNewLabel=ModLabel
End Function
Related pages

...

Navigate from here