使用Excel导出一个XML元素，后跟一个或多个相关元素
我有问题获得excel允许我，编辑后，导出一个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_LINE项目。 PO_LINE中的PO_NUM与PO中的PO_NUM相匹配。
如果我使用开发人员选项卡/ XML /导入function将其导入Excel，则excel格式化数据，如下所示：
如果我然后尝试使用导出选项在Developer / XML / Export下导出数据从Excel中出现此错误消息：
我已经尝试导入XML作为一个XML映射，然后单独映射列，但我仍然得到相同的错误消息。
我曾尝试在Visual Studio中创build一个XSD文件 – XML – >创build架构 – 然后将其导入为Excel中的XML映射，但是这种方法仍然存在相同的问题。
我已经阅读了微软在这里的文章，但我一直无法find解决scheme。
我是否需要在Excel中以某种方式格式化数据？ 有什么我可以添加到XSD，使其工作？
编辑：道歉，如果我错过了赏金截止date，我还没有能够尝试这些答案呢。 如果我错过赏金赏金，一旦我有机会尝试这些解决scheme，我会重新发放赏金，然后立即予以奖励。 感谢您的耐心等待！
编辑： [v2.0]
已更新为具有所需function的基本Excel应用程序。 （旧版本可在这里 。）
安装：
- 将2个代码块复制到每个块顶部注释中指示的模块中。
- 确保启用了两个库引用
Microsoft Scripting Runtime和Microsoft XML（VBE> Tools> References）
用法：
- 通过标准方式导入文件（开发人员>导入）。 新的工作表总是被创build。
- 编辑数据。 （插入，删除，复制和粘贴所有的工作。）
- 单击左上angular的
EXPORT伪button导出。 工作表将在之后自动删除。 - 单击
Close伪button，或手动closures工作表以放弃编辑。
笔记：
- 有效的单元格以绿色突出显示。 任何红色都是无效的，导出时会被忽略。
- 红色突出显示的最后一行是故意的，允许在最后追加新的logging。
- 导出的输出不缩进。
- 撤销在此刻被破坏。
- 一些小毛病也存在。
好东西：
'=============================================================================== ' 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 'ie 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
说明 ：
更新的解释即将推出
注意：如果您对我的variables命名惯例感到好奇，它基于RVBA 。
我从这里尝试了VBA代码，它在testing你的示例时将数据从Excel导出到XML。 这也照顾list of lists错误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
参考文献：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
