将 Excel 导出为 XML

Sub ExportToXML()
    Dim wsn As String
    Dim ws As Worksheet
    Dim xmlFile As String
    Dim rowNum As Long
    Dim colNum As Long
    Dim totalCols As Long
    Dim selectedPath As String
    Dim fileNumber As Integer
    Dim rowArray() As Variant   ' Store row data as an array
    Dim colHeaders() As Variant ' Store column headers as an array
    Dim xmlData() As String     ' Store XML data as an array
    Dim xmlDataIdx As Long

    ' Disable screen updating and automatic calculation
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    wsn = Application.InputBox("请输入需要导出的工作表名称", Type:=2)
    If wsn <> "" Then
        On Error Resume Next
        Set ws = ThisWorkbook.Sheets(wsn)
        On Error GoTo 0

        If ws Is Nothing Then
            MsgBox "未选择工作表。操作已取消。", vbExclamation
            Exit Sub
        End If
    End If

    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
            selectedPath = .SelectedItems(1)
        Else
            MsgBox "未选择保存路径。操作已取消。", vbExclamation
            Exit Sub
        End If
    End With

    xmlFile = selectedPath & "\" & ws.Name & "_exported.xml"

    totalCols = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
    colHeaders = ws.Range(ws.Cells(1, 1), ws.Cells(1, totalCols)).Value  ' Store column headers

    ReDim xmlData(1 To (ws.Cells(ws.Rows.Count, "A").End(xlUp).Row - 1) * (3 + totalCols * 7)) As String
    xmlDataIdx = 1

    fileNumber = FreeFile
    Open xmlFile For Output As #fileNumber

    For rowNum = 2 To ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
        xmlData(xmlDataIdx) = "<row>"
        xmlDataIdx = xmlDataIdx + 1
        rowArray = ws.Range(ws.Cells(rowNum, 1), ws.Cells(rowNum, totalCols)).Value  ' Store row data

        For colNum = 1 To totalCols
            xmlData(xmlDataIdx) = "<"
            xmlDataIdx = xmlDataIdx + 1
            xmlData(xmlDataIdx) = colHeaders(1, colNum)
            xmlDataIdx = xmlDataIdx + 1
            xmlData(xmlDataIdx) = ">"
            xmlDataIdx = xmlDataIdx + 1
            xmlData(xmlDataIdx) = EncodeXML(rowArray(1, colNum))
            xmlDataIdx = xmlDataIdx + 1
            xmlData(xmlDataIdx) = "</"
            xmlDataIdx = xmlDataIdx + 1
            xmlData(xmlDataIdx) = colHeaders(1, colNum)
            xmlDataIdx = xmlDataIdx + 1
            xmlData(xmlDataIdx) = ">"
            xmlDataIdx = xmlDataIdx + 1
        Next colNum

        xmlData(xmlDataIdx) = "</row>"
        xmlDataIdx = xmlDataIdx + 1
        xmlData(xmlDataIdx) = vbCrLf
        xmlDataIdx = xmlDataIdx + 1
    Next rowNum

    Print #fileNumber, "<?xml version=""1.0"" encoding=""UTF-8""?>" & vbCrLf & "<data>" & vbCrLf & Join(xmlData, "") & "</data>"
    Close #fileNumber

    ' Re-enable screen updating and automatic calculation
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    MsgBox "数据已导出为 XML：" & xmlFile, vbInformation
End Sub

Function EncodeXML(ByVal text As String) As String
    text = Replace(text, "&", "&amp;")
    text = Replace(text, "<", "&lt;")
    text = Replace(text, ">", "&gt;")
    text = Replace(text, """", "&quot;")
    text = Replace(text, "'", "&apos;")
    EncodeXML = text
End Function