Я написал код для записи сводной таблицы в примитивный формат XML. Здесь я не следую предустановленной схеме, просто записывая иерархию сводной таблицы в XML. Чтобы это сработало, вы должны использовать форму контура, но не компактно (каждый новый уровень должен начинать новый столбец). Также код не ожидает промежуточных итогов или итоговых итогов, и ожидается только один уровень числовых данных в поле данных.
Ваш PT будет в приемлемом формате XML с узлами, названными в соответствии с заголовками PT, но названия подгрупп выходят как атрибуты, бесполезно называемые 'name ='. Таким образом, вы получаете XML, который читается как «Содержимое папки здесь».
См. Код ниже: еще одно оговорка, это не очень хорошо очищено.есть некоторые строки, которые никогда не пострадают от старых реализаций кода. Кроме того, перед отладкой есть остановка до конца - если вам нужно внести изменения в вывод и повторить шаги записи файла. Вывод записывается как текстовый файл с именем «txt.txt» на диске C :.
Редактирование и повторное использование при необходимости.
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
Это действительно полезно. Спасибо! – Milacay
Связанная статья больше не существует. – ray
@ray, я обновил ссылку со следующей версией ... Я предполагаю, что исходная ссылка указывала на версию 2003 года, которая больше не поддерживается Microsoft. –