Использование 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 следует один или несколько элементов PO_LINE. PO_NUM в PO_LINE соответствует PO_NUM в PO.

Если я импортирую это в Excel с помощью функции вкладки «Разработчик» / «XML / Импорт», Excel форматирует данные следующим образом:

скриншот импорта excel xml

Если я затем попытаюсь экспортировать данные из Excel с помощью опции «Экспорт» в разделе «Разработчик / XML / Экспорт», я получаю следующее сообщение об ошибке:

ошибка экспорта excel xml

Я попытался импортировать XML в виде XML-карты и затем сопоставить столбцы отдельно, но я все равно получаю то же сообщение об ошибке.

Я попытался создать XSD-файл в Visual Studio – XML ​​-> Создать схему – и затем импортировать это как XML-карту в excel, но этот метод по-прежнему имеет те же проблемы.

Я прочитал статью Microsoft здесь, но я не смог найти решение.

Нужно ли форматировать данные определенным образом в Excel? Есть ли что-нибудь, что я могу добавить в XSD, чтобы это работало?

EDIT: Извиняюсь, если я пропущу крайний срок награды, я еще не смог попробовать эти ответы. Если я пропущу награду за награду, как только я получу шанс попробовать эти решения, я повторно выдачу награду, а затем вознагражу ее немедленно. Спасибо за ваше терпение!

EDIT: [v2.0]

Обновлено до базового приложения Excel со всеми запрошенными функциями. (Старая версия доступна здесь .)

Монтаж:

  • Скопируйте 2 блока кода в модули, указанные в комментариях в верхней части каждого блока.
  • Убедитесь, что две ссылки библиотек: Microsoft Scripting Runtime и Microsoft XML включены (VBE> Инструменты> Ссылки)

Применение:

  • Импортируйте файл стандартным способом (Developer> Import). Всегда создается новый лист.
  • Редактирование данных. (Вставка, удаление, копирование и вставка всей работы).
  • Экспортируйте, щелкнув псевдо-кнопку 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 '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 

Объяснение :

Обновленное объяснение в ближайшее время


Примечание. Если вам интересно о моем соглашении об именах переменных, оно основано на RVBA .

Я попробовал код VBA отсюда, и он работал над тестированием вашего образца с экспортом данных из 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

введите описание изображения здесь

  • Есть ли способ заставить Excel сохранить атрибуты XML в корневом элементе?
  • Создайте XSD, который можно импортировать в EXCEL с ограничениями на основе значений элементов
  • Как преобразовать этот тип листа Excel XLS в правильный XML?
  • Как отлаживать «пространство имен по умолчанию для документа неверно» Ошибка анализа XML?
  • Как конвертировать XSD-файл в XLS
  • Как включить схему с xml
  • Лучшая практика использования разных входных данных и генерация XML на основе того же XSD в .NET.
  • Схема xsd от excel с идентификационными идентификаторами
  • Преобразование структуры xsd в excel
  • как создать утилиту для преобразования файла excel в .XSD?
  • Экспорт данных из Excel в XML с переменными элементами
  • Interesting Posts

    Не удалось извлечь содержимое текстового поля Powerpoint в Excel с помощью Excel VBA

    Проблемы с экспортом java-таблиц в excel

    Как получить значение из вложенного / помещенного в Excel объекта Excel – данные из json

    Как я могу предотвратить дублирование данных Microsoft ACE и JET в VB6 из первой строки в электронной таблице Excel?

    xlrd & openpyxl извлекает неправильные значения ячейки (Excel)

    URL EXCEL в домене

    Есть ли решение SaaS для преобразования таблиц Excel в PDF-файлы?

    Excel 2016 Password Protection с уникальным паролем и возможностью фильтровать строки

    Как переименовать экземпляр объекта массива в C Sharp

    Excel VBA. Как заполнить значения ListBox из диапазона переменных?

    Форматирование листа Excel с использованием apache POI

    Excel VBA – Извлечение числового значения в строке

    Использование ссылки на ячейку в строке подключения

    Форматирование номера от 1B, 1M, 10K и т. Д. До цифр в excel 2016

    Ошибка повторного применения фильтра на рабочей книге

    Давайте будем гением компьютера.