none
Help with VBA code in Excel 2007 (VSTO 2005) RRS feed

  • Question

  • I wonder if somebody can take a look and ideally rewrite the marked areas of the code below. At best it behaves very unstable if used within an Excel Add-in, mostly it fails.


    Sub Writeback(pcell As PivotCell, newval As Double)
    
    Dim adocmd As New adodb.Command
    
    Dim adocon As New adodb.Connection
    
    
    
    Dim pt As PivotTable
    
    Dim pcache As PivotCache
    
    Set pt = pcell.Parent
    
    Dim pf As PivotField
    
    Dim pitmlist(2) As PivotItemList
    
    Set pcache = pt.PivotCache
    
    Dim cmdtxt As String
    
    Dim itmtxt As String
    
    Dim oldcf As String
    
    Dim cubnam As String
    
    Dim i As Integer
    
                
    
    'Make sure Excel's connection is active
    
    If Not pcache.IsConnected Then
    
        pcache.MakeConnection
    
    End If
    
                
    
    
    
    'Get Excel session command object and also get handle to connection object
    
    Set adocmd.ActiveConnection = pcache.ADOConnection
    
    adocmd.ActiveConnection.BeginTrans
    
    
    
    'In cmdtxt we will build up command to send to AS 2000 to perform allocation
    
    cmdtxt = ""
    
    cmdtxt = cmdtxt & pcell.DataField.Name & ","
    
    
    
    'Add each page field to cmdtxt
    
    If pt.PageFields.Count > 0 Then
    
    '
    ' HERE!
    '

    For
    Each pf In pt.PageFields cmdtxt = cmdtxt & pf.CurrentPageName & "," Next pf End If Set pitmlist(1) = pcell.RowItems Set pitmlist(2) = pcell.ColumnItems Dim k As Integer For k = 1 To 2 If pitmlist(k).Count > 0 Then 'Add row fields to cmdtxt, if any in view 'itmtxt is temporary text holder. Only add lowest level of each dimension in view to cmdtxt itmtxt = "" oldcf = pitmlist(k)(1).Parent.CubeField.Name 'itmtxt = "" 'This loop only adds to cmdtxt when CubeField changes For i = 1 To pitmlist(k).Count If pitmlist(k)(i).Parent.CubeField.Name = oldcf Then '
    'HERE!
    '

    itmtxt = pitmlist(k)(i) Else cmdtxt = cmdtxt & itmtxt & "," oldcf = pitmlist(k)(i).Parent.CubeField.Name itmtxt = pitmlist(k)(i) End If Next i 'Last rowitem is always lowest level and so added to cmdtxt '
    'HERE
    ' itmtxt = pitmlist(k)(pitmlist(k).Count) cmdtxt = cmdtxt & itmtxt & "," End If Next k cubnam = "[" & pcache.CommandText & "]" 'Could be modified to use other AS 2000 allocation algorithms cmdtxt = "Update cube " & cubnam & " set (" & _ VBA.Left(cmdtxt, Len(cmdtxt) - 1) & ")=" & newval & " Use_Equal_increment" adocmd.CommandText = cmdtxt adocmd.CommandType = adodb.adCmdUnknown adocmd.Execute 'Transaction can be commited if desired and cube is read/write for user adocmd.ActiveConnection.CommitTrans 'adocon.CommitTrans 'Need to refresh PivotTable to see effect of allocation in view pcache.Refresh End Sub

    Any help is appreciated.
    Monday, March 30, 2009 11:45 AM

All replies

  • The VSTO forum supports the VSTO technology, which uses C# and/or VB.NET. VBA problems are not supported here and should be asked in the Excel.programming newsgroup. You'll find a link in the VSTO forum's Please Read First message.

    Whenever you post a question, please be sure to mention the version of Excel involved and what you're trying to achieve with the code. Also indicate in what way the code is "not working" - in detail.
    Cindy Meister, VSTO/Word MVP
    Monday, March 30, 2009 5:08 PM
  • It is not a VBA problem, it is a missing statement or CAST that I need to dod to get the code working within an Excel Add-in. So I believe this is the correct place for my question.
    Thursday, April 2, 2009 11:52 AM