I wrote up some code to write a pivot table to a primitive XML format. Here I am not following any pre-set schema, just writing the pivot table heirarchy to XML. For this to work, you must use the outline form but not-compact (each new level should start a new column). Also the code expects no subtotals or grand totals, and only one level of numeric data in the data field is expected.
Your PT will be in an acceptable XML format with nodes named according to the PT headers, but the sub group titles come out as attributes unhelpfully named 'name ='. So you get XML that reads like - "Folder contents here".
See code below:
one other caveat, this has not been cleaned up very well. there are some lines that will never get hit from old implementations of the code. Also, there is a stop right before the end for debugging - in case you need to make a change to the output and redo the file writing steps. Output is written as a text file named 'txt.txt' in the C: drive.
Edit and re-use as needed.
Private Sub XMLWriter()
Dim sht As Worksheet: Set sht = ActiveSheet
'Debug.Print "The current Sheet is " & sht.Name
Dim pt As PivotTable: Set pt = sht.PivotTables(1)
'Debug.Print "Pivot Table name is " & pt.Name
Dim begin As String: begin = pt.TableRange1.Cells(1, 1).Address
Dim rows As Integer: rows = pt.TableRange1.rows.Count
Dim LastCell As Range: Set LastCell = pt.TableRange1.Cells(rows, 1)
If LastCell.PivotCell.PivotCellType = xlPivotCellGrandTotal Then Set LastCell = LastCell.Offset(-1, 0)
If LastCell.PivotCell.PivotCellType = xlPivotCellSubtotal Then Stop 'not implemented routine does not expect subtotals in rows - (will not create good xml)
Dim LastRow As Integer: LastRow = LastCell.Row
Dim celly As Range: Set celly = sht.Range(begin)
Dim level As Integer: level = 1
Dim levels As Integer: levels = 0 ' PRECEEDING CODE INITIALIZED VARIABLES - Depends on Pivot table in active worksheet (first on sheet, assumes only one on sheet)
Do 'determines nesting depth
If celly.Offset(0, levels + 1).Value = "" Then
levels = levels + 1
Exit Do
Else: levels = levels + 1
End If
Loop
'Stop
Dim dataFieldPresent As Boolean
Dim ShutDown As Boolean
If celly.Offset(levels - 1, levels - 1).PivotCell.PivotCellType = xlPivotCellValue Then
levels = levels - 1
dataFieldPresent = True
End If
'Stop
Dim ary() As String ' initializes array
ReDim ary(1 To levels, 7) As String ' based on nesting depth, seven placeholders set to accomadate data
Dim n As Integer
For n = LBound(ary) To UBound(ary) ' populates 'folder' names from pivottable headings
ary(n, 0) = celly.Offset(0, n - 1).Value ' 0 based folder holds name, or already completed xml group's string/data
ary(n, 1) = gettabs(n) & Cap(ary(n, 0)) ' 1 based folder holds node's'front cap' following xml syntax
ary(n, 2) = Cap("/" & ary(n, 0)) & vbCrLf ' 2 based folder holds 'end cap' to close node
ary(n, 0) = ""
Next
Set celly = celly.Offset(1, 0)
If celly.Value = "" Then Stop ' error occurred, there must be a cell in first column position at first row under Row Heading
ary(level, 3) = nameElement(celly.Value) & vbCrLf ' get value in current cell to name folder 'ary(level, 4) = nameElement("/" & celly.Value) ' level 4 was created for old implementation, no longer used
Dim tabs As String
'Stop
'tabs = gettabs(level)
ary(level, 6) = ary(level, 2) & vbCrLf
ary(level, 5) = ary(level, 1) & ary(level, 3) & vbCrLf
Dim lvlref As Integer: lvlref = 1
Dim addcrlf As String: addcrlf = vbCrLf
Do
Set celly = celly.Offset(1, -(celly.Column - 1))
' If celly.Row = 780 Then Stop
If celly.Row = LastRow Then ShutDown = True
If celly.Value = "Liabilities" Then Stop
If Not celly.Value = "" Then
closetoplevel
level = 1
ary = levelup(ary, level, lvlref, levels)
ary(level, 3) = nameElement(celly.Value) & vbCrLf
' ary(level, 4) = nameElement("/" & celly.Value)
ary(level, 5) = ary(level, 5) & gettabs(level) & ary(level, 3)
ary(level, 6) = ary(level, 3)
ary(level, 7) = celly.Value
writeout ary(1, 0)
' Stop
Else
level = 2
Do
Set celly = celly.Offset(0, 1)
On Error GoTo Term:
Nam = celly.PivotCell.PivotCellType ' error trap - should always be in pivot table
On Error GoTo 0
If celly.Value = "" Then
level = level + 1
Else
Exit Do
End If
Loop
getPosition (celly.Cells(1))
' If level = lvlref And level > 2 Then Stop ' update: seems to work fine after refactoring code originally ('not implemented - code does not expect given schema structure"
If level < lvlref Then
'Stop
ary = levelup(ary, level, lvlref, levels)
'getPosition (celly.Cells(1))
'Stop
lvlref = level - 1
GoTo ReInsertionPoint:
Else
ReInsertionPoint:
If level = levels Then
addcrlf = ""
Else: addcrlf = vbCrLf
End If
ary(level, 3) = nameElement(celly.Value) & addcrlf
If level = levels And dataFieldPresent = True Then
' Stop
ary(level, 3) = ary(level, 3) & CStr(celly.Offset(0, 1).Value)
End If
ary(level, 5) = ary(level, 5) & ary(level, 3)
ary(level, 6) = ary(level, 3)
ary(level, 7) = celly.Value
If level = levels Then ' XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX not operating properly failing to add last item (number & accoiunt) of each section
' Stop
Dim nextlevel As Integer: nextlevel = 1
'Stop
Dim nextlvlcell As Range: Set nextlvlcell = celly.Offset(1, -(level - 1))
Debug.Print nextlvlcell.Address
Do
If nextlvlcell.Value = "" Then
If nextlvlcell.Row > LastRow Then
nextlevel = 1
GoTo Closure:
Else
Set nextlvlcell = nextlvlcell.Offset(0, 1)
nextlevel = nextlevel + 1
End If
Else: Exit Do
End If
Loop
Debug.Print nextlvlcell.Address
If level - nextlevel > 1 Then
Closure:
'Stop
ary = pushup(ary(), level, levels, lvlref)
'Stop
ary = levelup(ary(), level - 1, levels, lvlref)
Else
ary = pushup(ary, level, levels, lvlref)
End If
End If
'Stop
End If
End If
lvlref = level
If ShutDown = True Then
level = 1
ary = levelup(ary, level, lvlref, levels)
Exit Do
End If
Loop
writeout "<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?>" & vbCrLf & "<Root xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"">" & vbCrLf & ary(1, 0) & "</Root>"
Stop
End
Term:
Stop
writeout "<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?>" & vbCrLf & "<Root xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"">" & vbCrLf & "<xmldoc>" & vbCrLf & ary(1, 0) & "</xmldoc>" & vbCrLf & "</Root>"
'writeout (ary(1, 0))
Stop
Exit Sub
'created by derik bingner Jan 2014 www.dbexcelaccounting.blogspot.com
End Sub
Private Sub getPosition(x As Range)
Debug.Print "Cell addy is " & x.Address & ". Cell level and text is " & x.Column & " - " & x.Value
End Sub
Private Function gettabs(x As Integer, Optional y As Integer) As String
For n = 1 To (x) ' - y) old implementation allowed offsets
gettabs = vbTab & "" & gettabs
Next
'If ((x * 2) - y) = 8 Then Stop
End Function
Private Function cnam(c As Range)
cnam = c.Value
End Function
Private Function Cap(x As String) As String
If Left(x, 1) = "/" Then
Cap = "</" & Right(x, Len(x) - 1) & ">"
Else: Cap = "<" & x & " name="""
End If
End Function
Private Function nameElement(x As String) As String
nameElement = x & """>"
End Function
Private Sub closetoplevel()
'Stop
'not implemented
End Sub
Private Function pushup(r() As String, l As Integer, s As Integer, ref As Integer)
Dim x As Integer: x = ref - l - 1
'Stop
'If ref <> s Then
' MsgBox "error, structure issue - not implemented"
' Stop
'End If
Dim y As Integer
If x > 1 Then ' tests if this function needs to be run recursively to step up multiple levels
For y = 1 To x - 1
Dim groupnumber As Integer
'Stop
If y <> 2 And InStr(1, r(l + 1, 0), "<") > 0 Then
groupnumber = 2
Else: groupnumber = 2 + y - 1
End If
'If groupnumber = 2 Then Stop
Call rlevelup(r, l + (x - y), s, ref, groupnumber) ' recursive section
'Stop
Next
End If
'Stop
If r(l, 5) = r(l, 3) Then ' this triggers for first item in group
'Stop
r(l, 5) = r(l, 1) & r(l, 5) & r(l, 2)
Else
If y = 0 Then
r(l, 5) = r(l, 1) & r(l, 5) & r(l, 2) & vbCrLf
Stop
Else
r(l, 5) = r(l, 5) & vbCrLf & r(l + 1, 5) & vbCrLf & gettabs(l, -1) & r(l, 4) & vbCrLf
' Stop
End If
End If
'Debug.Print r(l, 5)
Dim PlaceHolder As String: PlaceHolder = r(l, 0)
If Left(PlaceHolder, 1) = vbTab Or Left(PlaceHolder, 4) = " " Or Left(PlaceHolder, 1) = "<" Then
'Debug.Print PlaceHolder
Else
PlaceHolder = ""
End If
r(l, 0) = PlaceHolder & r(l, 5)
'Stop
For n = LBound(r) To UBound(r)
If n >= l Then
For i = 3 To 7
If r(n, i) <> r(l, 5) Then r(n, i) = ""
Next
End If
Next
r(l, 3) = r(l, 5)
r(l, 5) = ""
'Stop
'not implemented
pushup = r
End Function
Private Function levelup(r() As String, l As Integer, s As Integer, ref As Integer)
Dim x As Integer: x = s - l - 1
'If x > 3 Then Stop
'r = pushup(r(), s - 1, s, ref)
'If ref <> s Then
' MsgBox "error, structure issue - not implemented"
' Stop
'End If
Dim y As Integer
If x > 1 Then ' tests if this function needs to be run recursively to step up multiple levels
For y = 1 To x - 1
Dim groupnumber As Integer
'Stop
If y <> 2 And InStr(1, r(l + 1, 0), "<") > 0 Then
groupnumber = 2
Else: groupnumber = 2 + y - 1
End If
'Stop
'If groupnumber = 2 Then Stop
Call rlevelup(r, l + (x - y), s, ref, groupnumber) ' recursive section
'Stop
Next
End If
'Stop
If r(l, 5) = r(l, 3) Then ' this triggers for first item in group
'Stop
r(l, 5) = r(l, 1) & r(l, 5) & gettabs(l) & r(l, 2) & vbCrLf
Else
If y = 0 Then
r(l, 5) = r(l, 1) & r(l, 5) & gettabs(l) & r(l, 2) & vbCrLf
Stop
Else
r(l, 5) = r(l, 5) & vbCrLf & r(l + 1, 5) & vbCrLf & gettabs(l, -1) & r(l, 4) & vbCrLf
' Stop
End If
End If
'Debug.Print r(l, 5)
Dim PlaceHolder As String: PlaceHolder = r(l, 0)
If Left(PlaceHolder, 1) = vbTab Or Left(PlaceHolder, 4) = " " Or Left(PlaceHolder, 1) = "<" Then
'Debug.Print PlaceHolder
Else
PlaceHolder = ""
End If
r(l, 0) = PlaceHolder & r(l, 1) & r(l, 3) & r(l + 1, 0) & gettabs(l) & r(l, 2)
r(l + 1, 0) = ""
'Stop
For n = LBound(r) To UBound(r)
If n >= l Then
For i = 3 To 7
If r(n, i) <> r(l, 5) Then r(n, i) = ""
Next
End If
Next
'r(l, 3) = r(l, 5)
r(l, 5) = ""
'Stop
'not implemented
levelup = r
End Function
Private Function rlevelup(r() As String, l As Integer, s As Integer, ref As Integer, Optional groupnumber As Integer)
Dim x As Integer: x = ref - l - 1
'Stop
'called by level up
'If ref <> s Then
' MsgBox "error, structure issue - not implemented"
' Stop
'End If
Dim y As Integer
If x > 1 Then ' tests if this function needs to be run recursively to step up multiple levels
For y = 1 To x - 1
'Dim groupnumber As Integer
'Stop
'If y <> 2 And InStr(1, r(l + 1, 0), "<") > 0 Then
groupnumber = 2
'Else: groupnumber = 2 + y - 1
'End If
'If groupnumber = 2 Then Stop
'Call rpushup(r, l + (x - y), s, ref, groupnumber) ' recursive section
'Stop
Next
End If
'Stop
If r(l, 5) = r(l, 3) Then ' this triggers for first item in group
'Stop
r(l, 5) = r(l, 1) & r(l, 5) & gettabs(l) & r(l, 2) & vbCrLf
Else
If y = 0 Then
r(l, 5) = r(l, 1) & r(l, 5) & gettabs(l) & r(l, 2) & vbCrLf
Stop ' delete this comment when stop hit programmatically - may be deletable
Else
r(l, 5) = r(l, 5) & vbCrLf & r(l + 1, 5) & vbCrLf & gettabs(l, -1) & r(l, 4) & vbCrLf
' Stop
End If
End If
'Debug.Print r(l, 5)
Dim PlaceHolder As String: PlaceHolder = r(l, 0)
If Left(PlaceHolder, 1) = vbTab Or Left(PlaceHolder, 4) = " " Or Left(PlaceHolder, 1) = "<" Then
'Debug.Print PlaceHolder
Else
PlaceHolder = ""
End If
r(l, 0) = PlaceHolder & r(l, 1) & r(l, 3) & r(l + 1, 0) & gettabs(l) & r(l, 2)
r(l + 1, 0) = ""
'Stop
For n = LBound(r) To UBound(r)
If n >= l Then
For i = 3 To 7
If r(n, i) <> r(l, 5) Then r(n, i) = ""
Next
End If
Next
'r(l, 3) = r(l, 5)
r(l, 5) = ""
'Stop
'not implemented
'writeout (r(l, 0))
rlevelup = r
End Function
Private Sub writeout(s As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim oFile As Object
Set oFile = fso.CreateTextFile("c:/txt.txt")
oFile.WriteLine s
oFile.Close
Set fso = Nothing
Set oFile = Nothing
End Sub
https://stackoverflow.com/questions/15365320
italiano
english
français
española
中国
日本の
العربية
Deutsch
한국어
Português
Russian
