Ich habe etwas Code geschrieben, um eine Pivot-Tabelle in ein primitives XML-Format zu schreiben. Hier folge ich keinem vorgegebenen Schema, sondern schreibe nur die Pivot-Tabellen-Hierarchie nach XML. Damit dies funktioniert, müssen Sie das Gliederungsformular verwenden, aber nicht-kompakt (jede neue Ebene sollte eine neue Spalte beginnen). Außerdem erwartet der Code keine Zwischensummen oder Gesamtsummen, und es wird nur eine numerische Datenebene im Datenfeld erwartet.
Ihr PT befindet sich in einem akzeptablen XML-Format mit Knoten, die nach den PT-Headern benannt sind, aber die Untergruppentitel werden als Attribute mit dem nicht hilfreichen Namen 'name =' ausgegeben. Sie erhalten also XML, das sich liest - "Ordnerinhalte hier".
Siehe Code unten: eine andere Einschränkung, das wurde nicht sehr gut gereinigt.Es gibt einige Zeilen, die nie von alten Implementierungen des Codes betroffen werden. Außerdem gibt es einen Stopp kurz vor dem Ende für das Debuggen - falls Sie eine Änderung an der Ausgabe vornehmen und die Schritte zum Schreiben der Datei wiederholen müssen. Die Ausgabe wird als Textdatei mit dem Namen 'txt.txt' im Laufwerk C: geschrieben.
Bearbeiten und erneut verwenden, wie erforderlich.
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
Das ist wirklich hilfreich. Vielen Dank! – Milacay
Der verlinkte Artikel existiert nicht mehr. – ray
@ray, Ich habe den Link mit den nächsten Verwandten aktualisiert ... Ich nehme an, der ursprüngliche Link zeigte auf eine 2003-Version, die nicht mehr von Microsoft unterstützt wird. –