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

Question

我在获取 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_LINE 中的 PO_NUM 与 PO 中的 PO_NUM 匹配。

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

如果我随后尝试使用 Developer/XML/Export 下的导出选项从 Excel 导出数据，我会收到此错误消息:

我已尝试将 XML 作为 XML 映射导入，然后分别映射列，但我仍然收到相同的错误消息。

我曾尝试在 Visual Studio 中创建一个 XSD 文件 - XML--> 创建架构 - 然后将其作为 XML 映射导入到 excel 中，但这种方法仍然存在相同的问题。

我已经通读了微软的文章here但我一直无法找到解决方案。

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

编辑:如果我错过赏金截止日期，我深表歉意，我还无法尝试这些答案。如果我错过了奖励，一旦我有机会尝试这些解决方案，我将重新发布赏金，然后立即奖励它。感谢您的耐心等待!

Answer 1

编辑: [v2.0]

已更新为具有所有请求功能的基本 Excel 应用程序。 (旧版本可用 here 。)

安装:

• 将 2 个代码块复制到每个 block 顶部注释中指示的模块中。
• 确保两个库引用Microsoft Scripting Runtime 和 Microsoft XML 已启用(VBE > 工具 > 引用)

用法:

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

注意事项:

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

---

好东西:

'===============================================================================
' 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 的.