我在获取 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 以使其工作的吗？
编辑:如果我错过赏金截止日期，我深表歉意，我还无法尝试这些答案。如果我错过了奖励，一旦我有机会尝试这些解决方案，我将重新发布赏金，然后立即奖励它。感谢您的耐心等待!
最佳答案
编辑: [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 的.
关于xml - 使用 Excel 导出一个 XML 元素后跟一个或多个相关元素，我们在Stack Overflow上找到一个类似的问题： https://stackoverflow.com/questions/45736517/