Tôi đã viết một số mã để viết bảng tổng hợp thành định dạng XML nguyên thủy. Ở đây tôi không tuân theo bất kỳ lược đồ được thiết lập trước nào, chỉ cần viết bảng heirarchy pivot vào XML. Để làm việc này, bạn phải sử dụng biểu mẫu phác thảo nhưng không nhỏ gọn (mỗi cấp độ mới sẽ bắt đầu một cột mới). Ngoài ra, mã sẽ không có tổng phụ hoặc tổng số lớn và chỉ có một cấp dữ liệu số trong trường dữ liệu được mong đợi.
PT của bạn sẽ ở định dạng XML có thể chấp nhận được với các nút được đặt tên theo tiêu đề PT, nhưng tiêu đề nhóm phụ xuất hiện dưới dạng thuộc tính không tên được đặt tên 'name ='. Vì vậy, bạn nhận được XML mà đọc như - "Nội dung thư mục ở đây".
Xem mã bên dưới: một lưu ý khác, điều này chưa được làm sạch rất tốt.có một số dòng sẽ không bao giờ bị ảnh hưởng từ việc triển khai mã cũ. Ngoài ra, có một điểm dừng ngay trước khi kết thúc để gỡ lỗi - trong trường hợp bạn cần thực hiện thay đổi đối với đầu ra và làm lại các bước ghi tệp. Đầu ra được viết dưới dạng tệp văn bản có tên 'txt.txt' trong ổ C:.
Chỉnh sửa và sử dụng lại nếu cần.
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
Điều này thực sự hữu ích. Cảm ơn bạn! – Milacay
Bài viết được liên kết không còn tồn tại. – ray
@ray, tôi đã cập nhật liên kết với người thân sắp tới ... Tôi cho rằng liên kết ban đầu chỉ đến phiên bản 2003, không còn được hỗ trợ bởi Microsoft nữa. –