使用Excel导出一个XML元素，后跟一个或多个相关元素

Question

我遇到问题，在编辑之后，允许我导出XML文档，其中有一个元素的序列，后跟相关元素

这有点难以解释，所以我会尽力而为。如果您需要更多信息，请告诉我，我会更新问题。

我有一个XML文档，如下所示：

<?xml version="1.0" encoding="utf-8" standalone="yes"?>
<PRODUCT_XML>
  <PO>
    <PO_NUM>100002</PO_NUM>
    <SUPPLIER_CODE>967</SUPPLIER_CODE>
    <ORDER_DATE>03-05-2017</ORDER_DATE>
    <DATE_REQUIRED>15-03-2017</DATE_REQUIRED>
    <LOCATION_CODE>LOC1</LOCATION_CODE>
    <COMMENTS></COMMENTS>
    <STATUS>O</STATUS>
  </PO>
    <PO_LINE>
      <PO_NUM>100002</PO_NUM>
      <PO_ITEM>121</PO_ITEM>
      <STOCK_CODE>6925</STOCK_CODE >
      <QUANTITY>480</QUANTITY>
    </PO_LINE>
      <PO_LINE>
      <PO_NUM>100002</PO_NUM>
      <PO_ITEM>122</PO_ITEM>
      <STOCK_CODE>6926</STOCK_CODE >
      <QUANTITY>300</QUANTITY>
    </PO_LINE>
  <PO>
    <PO_NUM>100003</PO_NUM>
    <SUPPLIER_CODE>100</SUPPLIER_CODE>
    <ORDER_DATE>21-08-2017</ORDER_DATE>
    <DATE_REQUIRED>31-08-2017</DATE_REQUIRED>
    <LOCATION_CODE>LOC2</LOCATION_CODE>
    <COMMENTS></COMMENTS>
    <STATUS>O</STATUS>
  </PO>
    <PO_LINE>
      <PO_NUM>100003</PO_NUM>
      <PO_ITEM>123</PO_ITEM>
      <STOCK_CODE>5985</STOCK_CODE >
      <QUANTITY>200</QUANTITY>
    </PO_LINE>
</PRODUCT_XML> 

格式是每个PO项后跟一个或多个PO_LINE项。 PO_LINE中的PO_NUM与PO中的PO_NUM匹配。

如果我使用Developer Tab / XML / Import功能将其导入Excel，excel会格式化这样的数据：

如果我尝试使用Developer / XML / Export下的Export选项从Excel导出数据，则会显示以下错误消息：

我尝试将XML导入为XML Map，然后单独映射列，但我仍然收到相同的错误消息。

我尝试在Visual Studio中创建XSD文件 - XML - ＆gt;创建架构 - 然后将其导入为excel中的XML映射，但此方法仍存在相同的问题。

我已阅读微软here的文章，但我找不到解决方案。

我是否需要在Excel中以某种方式格式化数据？有什么我可以添加到XSD以使其工作？

编辑：如果我错过赏金截止日期，我很抱歉，我还没有能够尝试这些答案。如果我错过奖励赏金，一旦我有机会尝试这些解决方案，我将重新发放赏金，然后立即奖励它。感谢您的耐心等待！

Answer 1

编辑： [v2.0]

已更新为具有所有要求功能的基本Excel应用。 （旧版本可用here。）

<强>安装：

• 将2个代码块复制到每个块顶部注释中指示的模块中。
• 确保两个库引用 已启用Microsoft Scripting Runtime和Microsoft XML（VBE＆gt;工具＆gt;参考）

<强>用法：

• 通过标准方式导入文件（开发人员＆gt;导入）。始终会创建一个新工作表。
• 编辑数据。 （插入，删除，复制和粘贴所有作品。）
• 单击左上角的EXPORT伪按钮导出。之后工作表将自动删除。
• 点击Close伪按钮，或手动关闭工作表以放弃修改。

备注：

• 有效单元格以绿色突出显示。任何红色都无效，导出时将被忽略。
• 红色突出显示的最后一行是故意的，允许在最后追加新记录。
• 导出的输出不是缩进的。
• 目前已撤消撤消。
• 也存在一些小故障。

好东西：

'===============================================================================
' Module     : <in any standard module>
' Version    : 2.0
' Part       : 1 of 2
' References : Microsoft Scripting Runtime + Microsoft XML
' Online     : https://stackoverflow.com/a/45923978/1961728
'===============================================================================
Option Explicit

Public Const l_EXPORT As String = "EXPORT"
Public Const l_Close As String = "Close"
Public Const l_Type As String = "Type"
Public Const s_ButtonsAndTypeHeader As String = l_EXPORT & " " & l_Close & " " & l_Type
Public Const s_TextNumberFormat As String = "@"
Public Const s_Separator As String = ">"
Public Const s_HashBase As String = "000"

Private Const l_xml = "xml"
Private Const s_ProcessingInstructions = "version='1.0' encoding='utf-8' standalone='yes'"
Private Const l_PRODUCT_XML As String = "PRODUCT_XML"
Private Const l_PO As String = "PO"
Private Const l_PO_LINE As String = "PO_LINE"
Private Const s_ParentNodeNames As String = l_PO & " " & l_PO_LINE
Private Const s_POitemNames As String = "PO_NUM SUPPLIER_CODE ORDER_DATE DATE_REQUIRED LOCATION_CODE COMMENTS STATUS"
Private Const s_PO_LINEitemNames As String = "PO_NUM PO_ITEM STOCK_CODE QUANTITY"
'Pseudo-Constants
Public Function n_HeaderRowCount() As Long
  Static slngHeaderRowCount As Long
  If slngHeaderRowCount = 0 Then
    slngHeaderRowCount = Len(s_ButtonsAndTypeHeader) - Len(Replace(s_ButtonsAndTypeHeader, " ", "")) + 1
  End If
  n_HeaderRowCount = slngHeaderRowCount
End Function
Public Function n_DummyRecordIndex() As Long
  Static slngDummyRecordIndex As Long
  If slngDummyRecordIndex = 0 Then
    slngDummyRecordIndex = n_HeaderRowCount + 1
  End If
  n_DummyRecordIndex = slngDummyRecordIndex
End Function
Public Function n_FirstRecordIndex() As Long
  Static slngFirstRecordIndex As Long
  If slngFirstRecordIndex = 0 Then
    slngFirstRecordIndex = n_DummyRecordIndex + 1
  End If
  n_FirstRecordIndex = slngFirstRecordIndex
End Function
Public Function s_NameHashLikeness() As String
  Static sstrNameHashLikeness As String
  If sstrNameHashLikeness = vbNullString Then
    sstrNameHashLikeness = "*" & s_Separator & String$(Len(s_HashBase), "?")
  End If
  s_NameHashLikeness = sstrNameHashLikeness
End Function

Public Sub ImportXML _
           ( _
                      ByRef FilePath As String _
           )
       Dim Ä As Excel.Application: Set Ä = Excel.Application
       Dim pstrFilePath As String: pstrFilePath = FilePath

  Dim xmlDocument As MSXML2.DOMDocument
  Dim elmRecord As MSXML2.IXMLDOMElement
  Dim elmItem As MSXML2.IXMLDOMElement
  Dim strRecordType As String
  Dim dictItem2ColIndexes As Scripting.Dictionary
  Dim strKey As String
  Dim varChildNodeName As Variant
  Dim rngRecordHeaders As Range
  Dim rngCurrentRecord As Range
  Dim strFileNameBase As String

  Ä.ScreenUpdating = False

  ' Load XML DOM from file
  Set xmlDocument = New MSXML2.DOMDocument
  xmlDocument.Load pstrFilePath

  'Set up header stuff
  strFileNameBase = Mid$(pstrFilePath, InStrRev(pstrFilePath, "\") + 1)
  If LCase(Right$(strFileNameBase, 4)) = ".xml" Then
    strFileNameBase = Left$(strFileNameBase, Len(strFileNameBase) - 4)
  End If
  Set dictItem2ColIndexes = TheItem2ColIndexesDict(WithSheetHeadersSetup:=True, SheetName:=strFileNameBase)
  With ActiveSheet.Rows(n_HeaderRowCount)
    Set rngRecordHeaders = Range(.Cells(1), .Cells(dictItem2ColIndexes.Count + 1)) ' +1 for "Type" header
  End With

  ' Import XML DOM into active worksheet
  'Ä.ScreenUpdating = True ' Uncomment to show loading progress (could be VERY slow); Comment to hide (a lot faster)
  Set rngCurrentRecord = rngRecordHeaders.Offset(1)
  rngCurrentRecord.Cells(1).Value = l_PO 'Dummy (to be) hidden record - allows correctly formatted insertion below header
  For Each elmRecord In xmlDocument.DocumentElement.ChildNodes
    Set rngCurrentRecord = rngCurrentRecord.Offset(1)
    With rngCurrentRecord
    .Cells(1).Value = elmRecord.nodeName
    For Each elmItem In elmRecord.ChildNodes
      strKey = elmRecord.nodeName & s_Separator & elmItem.nodeName  'eg "PO>PO_NUM"
      .Cells(dictItem2ColIndexes(strKey)).Value = elmItem.Text
    Next elmItem
    End With
  Next elmRecord
  Ä.ScreenUpdating = False

  'Setup formatting
  With rngRecordHeaders
    .EntireColumn.AutoFit 'Re-AutoFit
    With .Offset(1).Resize(rngCurrentRecord.Row - .Row + 2, .Columns.Count) ' 2 extra empty records at bottom
      .Interior.Color = 5296274 'Light Green
      .Borders.ThemeColor = 1
      With .FormatConditions.Add( _
            Type:=xlExpression, _
            Formula1:=Interpolate( _
                "=IF('{Type}'=A${HeadersRow},A1='',OR($A1='',AND(A1<>'',$A1<>INDEX($2:$2,MATCH('*',$A$2:A$2,-1)))))", _
                l_Type, n_HeaderRowCount))
        .Font.Bold = True
        .Font.ThemeColor = xlThemeColorDark1 '5% Off White
        .Interior.Color = 255 'Red
      End With
      With .FormatConditions.Add( _
            Type:=xlExpression, _
            Formula1:=Interpolate( _
                "=AND(NOT('{Type}'=A${HeadersRow}),A1='',$A1<>INDEX($2:$2,MATCH('*',$A$2:A$2,-1)))", _
                l_Type, n_HeaderRowCount))
        .Font.Bold = True
        .Font.Color = 255 'Red
        .Interior.TintAndShade = -0.05 '5% Off White
      End With
      .Columns(1).Validation.Add _
          Type:=XlDVType.xlValidateList, _
          Formula1:=Replace(s_ParentNodeNames, " ", ",")
      .Columns(1).NumberFormat = s_TextNumberFormat ' For header anti-deletion code
    End With
    .Offset(1).EntireRow.Hidden = True ' Hide first (Dummy) record
    Range(Rows(rngCurrentRecord.Row + 2), Rows(Rows.Count)).Hidden = True ' + 2 -> show first extra empty record
  End With

  Unprotect ActiveSheet
  Cells.Locked = False
  Range(Rows(1), Rows(n_HeaderRowCount)).Locked = True
  Protect ActiveSheet
  Ä.Goto Cells(n_FirstRecordIndex, 1)
  Ä.Goto Cells(n_FirstRecordIndex, 1) ' Fixes one worksheet synch issue (prev line always sets PreviousSelections(1) to $A$1)

  Ä.ScreenUpdating = True

End Sub

Public Function ExportXML _
                ( _
                ) _
       As VBA.VbMsgBoxResult
       Dim Ä As Excel.Application: Set Ä = Excel.Application

  Dim xmlDocument As MSXML2.DOMDocument
  Dim elmRoot As MSXML2.IXMLDOMElement
  Dim elmRecord As MSXML2.IXMLDOMElement
  Dim elmItem As MSXML2.IXMLDOMElement
  Dim strRecordName As String
  Dim dictItem2ColIndexes As Scripting.Dictionary
  Dim dictRecordName2ItemNames As Scripting.Dictionary
  Dim varNodeNameArray As Variant
  Dim varItemName As Variant
  Dim rngRecordHeaders As Range
  Dim rngCurrentRecord As Range
  Dim varSaveFilePath As Variant

  'Set up header stuff
  Set dictItem2ColIndexes = TheItem2ColIndexesDict()
  With ActiveSheet.Rows(n_HeaderRowCount)
    Set rngRecordHeaders = Range(.Cells(1), .Cells(dictItem2ColIndexes.Count + 1)) ' +1 for "Type" (=record name) header
  End With
  Set dictRecordName2ItemNames = New Scripting.Dictionary
  For Each varNodeNameArray In Array(Array(l_PO, s_POitemNames), Array(l_PO_LINE, s_PO_LINEitemNames))
    dictRecordName2ItemNames.Add varNodeNameArray(0), Split(varNodeNameArray(1), " ")
  Next varNodeNameArray

  ' Create new XML DOM from target worksheet
  Set xmlDocument = New MSXML2.DOMDocument
  With xmlDocument
    .appendChild .createProcessingInstruction(l_xml, s_ProcessingInstructions)
    Set elmRoot = .createElement(l_PRODUCT_XML)
  End With
  Set rngCurrentRecord = rngRecordHeaders.Offset(1) ' First Record is a dummy hidden record so skip it
  Do While rngCurrentRecord.Cells(1).NumberFormat = s_TextNumberFormat: Do
    Set rngCurrentRecord = rngCurrentRecord.Offset(1)
    With rngCurrentRecord
      strRecordName = .Cells(1).Value2
      If strRecordName = vbNullString Then Exit Do ' Skip records with empty Names (=Types)
      Set elmRecord = xmlDocument.createElement(strRecordName)
      For Each varItemName In dictRecordName2ItemNames.Item(strRecordName)
        Set elmItem = xmlDocument.createElement(varItemName)
        elmItem.Text = .Cells(dictItem2ColIndexes(strRecordName & s_Separator & varItemName)).Value2
        elmRecord.appendChild elmItem
      Next varItemName
      elmRoot.appendChild elmRecord
    End With
  Loop While 0: Loop
  xmlDocument.appendChild elmRoot

  'Save XML DOM to file
  Do
    varSaveFilePath _
    = Application.GetSaveAsFilename _
        ( _
          Left$(ActiveSheet.Name, Len(ActiveSheet.Name) - 4), _
          "All Files (*.*), *.*, XML Files (*.xml), *.xml", _
          2, _
          "Export XML" _
        )
    If TypeName(varSaveFilePath) = "Boolean" Then
      ExportXML = vbCancel
    Else
      If Dir(varSaveFilePath) <> vbNullString Then
        If vbYes = MsgBox _
           ( _
             Title:="Confirm Save", _
             Prompt:=varSaveFilePath & " already exists." & vbCrLf & vbCrLf & "Do you want to replace it?", _
             Buttons:=vbExclamation + vbYesNo + vbDefaultButton2 _
           ) _
        Then
          xmlDocument.Save varSaveFilePath
          ExportXML = vbOK
        End If
      Else
        xmlDocument.Save varSaveFilePath
        ExportXML = vbOK
      End If
    End If
  Loop Until ExportXML

End Function

Private Function TheItem2ColIndexesDict _
                 ( _
                   Optional ByRef WithSheetHeadersSetup As Boolean = False, _
                   Optional ByRef SheetName As String = vbNullString _
                 ) _
        As Scripting.Dictionary
        Dim Ä As Excel.Application: Set Ä = Excel.Application
        Dim pWithSheetHeadersSetup As Boolean: pWithSheetHeadersSetup = WithSheetHeadersSetup
        Dim pstrSheetName As String: pstrSheetName = SheetName
        Dim × As Long: × = 0

  Dim lngHashLength As Long
  Dim wkstWorksheet As Worksheet
  Dim rngHeader As Range
  Dim varString As Variant
  Dim strHighestHash As String
  Dim varNodeNameArray As Variant
  Dim varChildNodeName As Variant
  Dim strParentNodeName As String
  Dim lngParentStartIndex  As Long
  Dim lngGrandParentStartIndex As Long

  Set TheItem2ColIndexesDict = New Scripting.Dictionary

  'Create and rename new worksheet if required
  If pWithSheetHeadersSetup Then
    With ThisWorkbook.Worksheets
      strHighestHash = s_HashBase
      For Each wkstWorksheet In .Parent.Worksheets
        With wkstWorksheet
          If .Name Like pstrSheetName & s_Separator & String$(n_HeaderRowCount, "?") _
          And (Right$(.Name, n_HeaderRowCount) > strHighestHash) _
          Then
            strHighestHash = Right$(.Name, 3)
          End If
        End With
      Next wkstWorksheet
      ' New worksheet name format is, for example, "MyFileNameIsBond>007" (from MyFileNameIsBond.xml)
      .Add(After:=.Parent.Worksheets(.Count)) _
          .Name _
          = pstrSheetName _
          & s_Separator _
          & Right$(String$(n_HeaderRowCount - 1, "0") & CStr(CLng(Right$(strHighestHash, 3)) + 1), 3)
    End With
  End If

  ' Set up Type Header (and pseudo-buttons above it)
  Set rngHeader = ActiveSheet.Rows(1)
  For Each varString In Split(s_ButtonsAndTypeHeader, " ")
    If pWithSheetHeadersSetup Then rngHeader.Cells(1) = varString
    Set rngHeader = rngHeader.Offset(1)
  Next varString

  'Construct dictionary of header indexes, setting up headers in newly created worksheet if required
  With rngHeader.Offset(-1)
    × = 1
    lngGrandParentStartIndex = × + 1
    For Each varNodeNameArray In Array(Array(l_PO, s_POitemNames), Array(l_PO_LINE, s_PO_LINEitemNames))
      strParentNodeName = varNodeNameArray(0)
      lngParentStartIndex = × + 1
      For Each varChildNodeName In Split(varNodeNameArray(1), " ")
        × = × + 1: TheItem2ColIndexesDict.Add strParentNodeName & s_Separator & varChildNodeName, ×
        If pWithSheetHeadersSetup Then
          .Cells(×).Value = varChildNodeName
          ' Dates require special handling to overcome Excel's mangled auto-typing
          If InStr(1, varChildNodeName, "dAtE", VbCompareMethod.vbTextCompare) Then
            .Cells(×).EntireColumn.NumberFormat = s_TextNumberFormat
          End If
        End If
      Next varChildNodeName
      If pWithSheetHeadersSetup Then
        With Range(.Cells(lngParentStartIndex).Offset(-1), .Cells(×).Offset(-1))
          .MergeCells = True
          .Value = strParentNodeName
          .HorizontalAlignment = xlCenter
        End With
      End If
    Next varNodeNameArray
    If pWithSheetHeadersSetup Then
      With Range(.Cells(lngGrandParentStartIndex).Offset(-2), .Cells(×).Offset(-2))
        .MergeCells = True
        .Value = l_PRODUCT_XML
        .HorizontalAlignment = xlCenter
      End With
      .AutoFilter
      .Cells(1).FormulaR1C1 = "=""" & .Cells(1).Value2 & """&REPT(COUNTA(OFFSET(C,,1)),)" ' Triggers a Calculate event on AutoFilter
      With .Offset(1 - n_HeaderRowCount).Resize(n_HeaderRowCount, ×)
        .EntireColumn.AutoFit
        .Font.Bold = True
        .Font.ThemeColor = XlThemeColor.xlThemeColorDark1 'White
        .Interior.ThemeColor = XlThemeColor.xlThemeColorAccent1 ' Blue
        .Borders.ThemeColor = 1
        With .Cells(1).Resize(n_HeaderRowCount - 1)
          .HorizontalAlignment = xlCenter
          .Interior.Color = 65535 'Yellow
          .Font.ColorIndex = xlAutomatic
          .Font.Size = .Font.Size - 1
        End With
      End With
      Range(.Cells(× + 1), .Cells(.Columns.Count)).EntireColumn.Hidden = True
      Ä.ScreenUpdating = True 'Show Headers
      Ä.ScreenUpdating = False
    End If
  End With

End Function

Private Sub Unprotect(ByRef TheWorksheet As Worksheet)
    TheWorksheet.Unprotect
End Sub

Private Sub Protect(ByRef TheWorksheet As Worksheet)
  With TheWorksheet
    .Protect _
        UserInterfaceOnly:=True, _
        Contents:=True, _
        AllowInsertingRows:=True, _
        AllowDeletingRows:=True, _
        AllowFormattingColumns:=True, _
        AllowFiltering:=True
    .EnableSelection = XlEnableSelection.xlNoRestrictions
  End With
End Sub

Private Function Interpolate(ByRef TheString, ParamArray Values() As Variant)
  Dim varValue As Variant
  Dim × As String: × = TheString
  For Each varValue In Values
    × = WorksheetFunction.Replace(×, InStr(×, "{"), InStr(×, "}") - InStr(×, "{") + 1, varValue)
  Next
  Interpolate = Replace(×, "'", """")
End Function

和

'===============================================================================
' Module     : ThisWorkbook
' Version    : 2.0
' Part       : 2 of 2
' References : N/A
' Online     : https://stackoverflow.com/a/45923978/1961728
'===============================================================================
Option Explicit

Private mIsWorkbookInitialized As Boolean
Private mColWasInserted As Boolean
Private mrngPreviousSelection As Range
Private mIgnoreDoubleClick_OneOff As Boolean

Private Sub Workbook_BeforeXmlImport _
            ( _
              ByVal Map As XmlMap, _
              ByVal URL As String, _
              ByVal IsRefresh As Boolean, _
              ByRef Cancel As Boolean _
            )
        Dim Ä As Excel.Application: Set Ä = Excel.Application

  Ä.EnableEvents = False
  Ä.ScreenUpdating = False
    If Selection.Row <> 1 Then Range(Rows(1), Rows(Selection.Row - 1)).Hidden = True
    If Selection.Column <> 1 Then
      Range(Columns(1), Columns(Selection.Column - 1)).Hidden = True
      Columns(Selection.Column - 1).Hidden = False
      mColWasInserted = False
    Else
      Columns(Selection.Column).Insert
      mColWasInserted = True
    End If
    If Map.WorkbookConnection.Ranges.Count = 0 Then ' Import is about to fail -> force Workbook_AfterXmlImport
      Workbook_AfterXmlImport Map, IsRefresh, 666
      Cancel = True ' Trap "XML Import Error" dialog
    End If
  Ä.ScreenUpdating = True
  Ä.EnableEvents = True

End Sub

Private Sub Workbook_AfterXmlImport _
            ( _
              ByVal Map As XmlMap, _
              ByVal IsRefresh As Boolean, _
              ByVal Result As XlXmlImportResult _
            )
        Dim Ä As Excel.Application: Set Ä = Excel.Application

  Ä.EnableEvents = False
  Ä.ScreenUpdating = False
    If mColWasInserted Then Columns(1).Delete
    Rows.Hidden = False
    Columns.Hidden = False
    With Map.WorkbookConnection.Ranges
      If .Count > 0 Then .Item(1).Delete 'i.e. Table.Delete
    End With
    ImportXML Map.DataBinding.SourceUrl
    Map.Delete ' Not deleting the map means Import Data dialog is skipped after first-run but only imports bound url
  Ä.ScreenUpdating = True
  Ä.EnableEvents = True

End Sub

Private Sub Workbook_SheetBeforeDoubleClick _
            ( _
              ByVal ThisSheet As Object, _
              ByVal Target As Range, _
              ByRef Cancel As Boolean _
            )

  If mIgnoreDoubleClick_OneOff Then
    mIgnoreDoubleClick_OneOff = False: Cancel = True: Exit Sub
  End If

End Sub

Private Sub Workbook_SheetBeforeRightClick _
            ( _
              ByVal ThisSheet As Object, _
              ByVal Target As Range, _
              ByRef Cancel As Boolean _
            )
        Dim Ä As Excel.Application: Set Ä = Excel.Application

  If Not ThisSheet.Name Like s_NameHashLikeness Then Exit Sub
  If Target.Rows.Count <> 1 Or Target.Columns.Count <> 1 Then Exit Sub

  Select Case Target.Cells(1).Value2
  Case l_EXPORT:
    Cancel = True 'Workbook_SheetSelectionChange takes care of this for now
  Case l_Close:
    Cancel = True 'Workbook_SheetSelectionChange takes care of this for now
  Case Else
    ' Ignore other cells
  End Select

End Sub

Private Sub Workbook_SheetSelectionChange _
            ( _
              ByVal ThisSheet As Object, _
              ByVal Target As Range _
            )
        Dim Ä As Excel.Application: Set Ä = Excel.Application

  Dim rngSavedSelection As Range
  If Target.Rows.Count <> 1 Or Target.Columns.Count <> 1 Then Exit Sub
  If ThisSheet.Index <> ActiveSheet.Index Then ' First-time selection in new sheet -> fix synchronization
    ' TODO - Need to synchronize cell rows with cursor in newly created worksheet
    ' Some part of  Excel still thinks we are in the previous worksheet since the "XML table in new sheet" checkbox is bypassed but we force a new sheet anyway
    ' Do via get cursor position api then select correct cell in activesheet
    Set Target = Range(Target.Address) ' Temporary - only works in column 1
  End If
  Select Case Target.Value2
  Case l_EXPORT:
    If ExportXML() = vbOK Then
      Ä.DisplayAlerts = False
        ActiveSheet.Delete
      Ä.DisplayAlerts = True
    End If
    Ä.Goto Ä.PreviousSelections(LBound(Ä.PreviousSelections))
    mIgnoreDoubleClick_OneOff = True ' TODO - Add timestamp to expire ignore
  Case l_Close:
    If MsgBoxClose = vbOK Then ActiveSheet.Delete
    On Error GoTo ExitSub:
    Ä.Goto Ä.PreviousSelections(LBound(Ä.PreviousSelections))
    On Error GoTo 0
    mIgnoreDoubleClick_OneOff = True
  Case Else
    ' Ignore other cells
  End Select
ExitSub:
  Ä.Goto Selection

End Sub

Private Sub Workbook_NewSheet(ByVal ThisSheet As Object)
'TODO - Trap "XML table in new sheet" radio button selected by saving last new sheet creation time
'        and this sheet's SheetChange counts
End Sub

Private Sub Workbook_SheetChange _
            ( _
              ByVal ThisSheet As Object, _
              ByVal Target As Range _
            )
  If Not ThisSheet.Name Like s_NameHashLikeness Then Exit Sub
  If ThisSheet.Index <> ActiveSheet.Index Then Exit Sub
End Sub

Private Sub Workbook_SheetCalculate _
            ( _
              ByVal ThisSheet As Object _
            )
        Dim Ä As Excel.Application: Set Ä = Excel.Application
        Dim ƒ As Excel.WorksheetFunction: Set ƒ = Excel.WorksheetFunction

  Dim rngLastRecord As Range
  Dim rngTypeCell As Range
  Dim lngTypeCellIndex As Long
  Dim lngHeaderCount As Long

'TODO - Fix this so Undo doesn't break - use Ä.Undo to store actions and undo handler
  If ThisSheet.Index <> ActiveSheet.Index Then Exit Sub
  If Not ThisSheet.Name Like s_NameHashLikeness Then Exit Sub

  Ä.EnableEvents = False
  Ä.ScreenUpdating = False
  ' Remove row insertions in header
  lngHeaderCount = 0
  Set rngTypeCell = Cells(1, 1)
  Do Until lngHeaderCount = n_HeaderRowCount
    With rngTypeCell
      lngTypeCellIndex = .Row
      If .Value2 = l_EXPORT Or .Value2 = l_Close Or .Value2 = l_Type Then ' Valid header -> count it
        lngHeaderCount = lngHeaderCount + 1
      ElseIf .NumberFormat = s_TextNumberFormat Then ' Some header(s) deleted -> undelete them (UNPROTECTED ONLY)
        Ä.Undo
        GoTo ExitSub:
      Else ' Row(s) inserted in headers -> delete them ## .Unprotect, .Delete and Ä.OnTime DON'T WORK IN _SheetChange ##
        lngTypeCellIndex = lngTypeCellIndex - 1 ' Backup one row so we recheck the new row at same index
        .EntireRow.Delete ' If Delete works, rngTypeCell is undefined
      End If
    End With
    Set rngTypeCell = ThisSheet.Cells(lngTypeCellIndex + 1, 1) ' Can't use rngTypeCell.Offset() as rngTypeCell may be undefined
  Loop
  If Rows(n_DummyRecordIndex).Hidden = False Then
    Rows(n_DummyRecordIndex).Hidden = True
  End If
  ' Find last record (.SpecialCells doesn't work here so use .End(xlUp) and then scan down checking NumberFormats)
  Set rngTypeCell = Cells(Rows.Count, 1).End(xlUp).Offset(1)
  Do
    Set rngTypeCell = rngTypeCell.Offset(1)
  Loop Until rngTypeCell.NumberFormat <> s_TextNumberFormat
  Set rngLastRecord = rngTypeCell.Offset(-1).Resize(1, ƒ.CountA(Rows(n_HeaderRowCount)))
  ' If only one empty record at the end, add another
  If ƒ.CountA(rngLastRecord.Offset(-1)) <> 0 Then
    With rngLastRecord
    .EntireRow.Hidden = False
    .Copy
    .Offset(1).PasteSpecial
    Ä.CutCopyMode = False
    Set rngLastRecord = .Offset(1)
    End With
  End If
  ' If more than two empty records at the end, remove the extras
  Do While ƒ.CountA(rngLastRecord.Offset(-2)) = 0
    rngLastRecord.Clear
    Set rngLastRecord = rngLastRecord.Offset(-1)
  Loop
  ' Re-hide records from last extra empty record down (extra rows get shown when user deletes rows)
  Range(Rows(rngLastRecord.Row), Rows(Rows.Count)).Hidden = True  ' -1 -> hide last extra empty record
ExitSub:
  Ä.ScreenUpdating = True
  Ä.EnableEvents = True

End Sub

Private Function MsgBoxClose() As VBA.VbMsgBoxResult
  MsgBoxClose _
  = MsgBox _
    ( _
      Title:="Discard XML", _
      Prompt:="Are you sure you want to close this worksheet?" & vbCrLf & vbCrLf & "Any changes will NOT be saved!", _
      Buttons:=vbExclamation + vbOKCancel + vbDefaultButton2 _
    )
End Function

<强>解释：

即将更新的说明

  

注意：如果您对我的变量命名约定感到好奇，那么它基于RVBA。

Answer 2

我尝试了来自here的VBA代码，它通过将数据从Excel导出到XML来测试您的示例。这也会处理list of lists错误。但首先要确保您已将xml保存以供代码参考。

Sub ExceltoXML()
    Dim fn As String, temp As String
    fn = "C:\test.xml"  '<- Change your file path
    temp = CreateObject("Scripting.FileSystemObject").OpenTextFile(fn).ReadAll
    temp = Replace(temp, vbCrLf, Chr(12))
    With CreateObject("VBScript.RegExp")
        .Pattern = Chr(12) & "*< PO_LINE >.+< /PO_LINE >" & Chr(12) & "*"  '<- Delete space
        temp = .Replace(temp, "")
    End With
    Open Replace(fn, "xml", "Revised.xml") For Output As #1
        Print #1, Replace(temp, Chr(12), vbCrLf)
    Close #1
End Sub

Answer 3

  

参考文献：   Microsoft XML 3

尝试使用以下内容。

Sub Extract()
    Dim increment As Variant
    Dim incrementrow As Variant
    incrementrow = 1
    increment = 1
    Dim XDoc As MSXML2.DOMDocument
    Dim xEmpDetails As MSXML2.IXMLDOMNode
    Dim xEmployee As MSXML2.IXMLDOMNode
    Dim xChild As MSXML2.IXMLDOMNode
    Set XDoc = New MSXML2.DOMDocument
    XDoc.async = False
    XDoc.validateOnParse = False
    ChDrive ("C:\")
    ChDir ("C:\work\xmlexample\")
    Files = Dir("*.xml")
    Do While Files <> ""
        XDoc.Load (Files)
        Set xEmpDetails = XDoc.DocumentElement
        Set xEmployee = xEmpDetails.FirstChild
        For Each xEmployee In xEmpDetails.ChildNodes
            If xEmployee.nodeName = "PO" Then
                increment = 1
                For Each xChild In xEmployee.ChildNodes
                    If xChild.nodeName = "PO_NUM" Then
                        Cells(incrementrow, increment) = xChild.Text
                        increment = increment + 1
                    ElseIf xChild.nodeName = "SUPPLIER_CODE" Then
                        Cells(incrementrow, increment) = xChild.Text
                        increment = increment + 1
                    ElseIf xChild.nodeName = "ORDER_DATE" Then
                        Cells(incrementrow, increment) = xChild.Text
                        increment = increment + 1
                    ElseIf xChild.nodeName = "DATE_REQUIRED" Then
                        Cells(incrementrow, increment) = xChild.Text
                        increment = increment + 1
                    ElseIf xChild.nodeName = "LOCATION_CODE" Then
                        Cells(incrementrow, increment) = xChild.Text
                        increment = increment + 1
                    ElseIf xChild.nodeName = "COMMENTS" Then
                        Cells(incrementrow, increment) = xChild.Text
                        increment = increment + 1
                    ElseIf xChild.nodeName = "STATUS" Then
                        Cells(incrementrow, increment) = xChild.Text
                        increment = increment + 1
                    End If
                Next xChild
            ElseIf xEmployee.nodeName = "PO_LINE" Then
                increment = 8
                For Each xChild In xEmployee.ChildNodes
                    If xChild.nodeName = "PO_NUM" Then
                        Cells(incrementrow, increment) = xChild.Text
                        increment = increment + 1
                    ElseIf xChild.nodeName = "PO_ITEM" Then
                        Cells(incrementrow, increment) = xChild.Text
                        increment = increment + 1
                    ElseIf xChild.nodeName = "STOCK_CODE" Then
                        Cells(incrementrow, increment) = xChild.Text
                        increment = increment + 1
                    ElseIf xChild.nodeName = "QUANTITY" Then
                        Cells(incrementrow, increment) = xChild.Text
                        increment = increment + 1
                    End If
                Next xChild
                incrementrow = incrementrow + 1
            End If
        Next xEmployee
    Loop
End Sub

<强> OP