Is there any way to make Excel preserve XML attributes in root element?

Okay, well I bit the bullet and wrote a good ol' VBA macro. I figured I'd share it with you all in case anyone else runs into the same problem.

This macro basically calls Excel's built-in XML Export() method then performs a series of text replacements on the resulting file. The text replacements are entirely up to you. Just place them in a worksheet like the one in the link below...

An example of how to set up the "replace rules": Click me for screen cap

In this example, I replaced tab with space-space, ":ns1" with blank, "ns1:" with blank, and the stripped-down root element with the original root element.

You can format your replace rules any way you like, just as long as you follow these instructions:

1. Select all the "find what" cells and give them the name* "FindWhat" (don't include a heading row in your selection; blanks will be ignored).
2. Select all the "replace with" cells and give them the name* "ReplaceWith" (there should be a one-to-one mapping between the "find what" and "replace with" cells; use blanks to remove unwanted text).
3. Enter the name of the XML Map somewhere in your workbook, and name that cell "XmlMap".
4. Run the Macro. (You will be asked to specify the file you want to export to.)

*If you are unfamiliar with naming ranges in Excel 2007, click the Formulas tab and choose Name Manager.

Okay, I won't keep you in suspense any longer (LOL)...here's the code for the macro. Just place it in a Module in the VBA editor. I offer no guarantees with this free code (you could easily break it if you don't name the ranges properly), but the couple examples I've tried have worked for me.

Option Explicit

Sub ExportXml()
    Dim exportResult As XlXmlExportResult
    Dim exportPath As String
    Dim xmlMap As String
    Dim fileContents As String
    exportPath = RequestExportPath()
    If exportPath = "" Or exportPath = "False" Then Exit Sub
    xmlMap = range("XmlMap")
    exportResult = ActiveWorkbook.XmlMaps(xmlMap).Export(exportPath, True)
    If exportResult = xlXmlExportValidationFailed Then
        Beep
        Exit Sub
    End If
    fileContents = ReadInTextFile(exportPath)
    fileContents = ApplyReplaceRules(fileContents)
    WriteTextToFile exportPath, fileContents
End Sub

Function ApplyReplaceRules(fileContents As String) As String
    Dim replaceWorksheet As Worksheet
    Dim findWhatRange As range
    Dim replaceWithRange As range
    Dim findWhat As String
    Dim replaceWith As String
    Dim cell As Integer
    Set findWhatRange = range("FindWhat")
    Set replaceWithRange = range("ReplaceWith")
    For cell = 1 To findWhatRange.Cells.Count
        findWhat = findWhatRange.Cells(cell)
        If findWhat <> "" Then
            replaceWith = replaceWithRange.Cells(cell)
            fileContents = Replace(fileContents, findWhat, replaceWith)
        End If
    Next cell
    ApplyReplaceRules = fileContents
End Function

Function RequestExportPath() As String
    Dim messageBoxResult As VbMsgBoxResult
    Dim exportPath As String
    Dim message As String
    message = "The file already exists. Do you want to replace it?"
    Do While True
        exportPath = Application.GetSaveAsFilename("", "XML Files (*.xml),*.xml")
        If exportPath = "False" Then Exit Do
        If Not FileExists(exportPath) Then Exit Do
        messageBoxResult = MsgBox(message, vbYesNo, "File Exists")
        If messageBoxResult = vbYes Then Exit Do
    Loop
    RequestExportPath = exportPath
End Function

Function FileExists(path As String) As Boolean
    Dim fileSystemObject
    Set fileSystemObject = CreateObject("Scripting.FileSystemObject")
    FileExists = fileSystemObject.FileExists(path)
End Function

Function ReadInTextFile(path As String) As String
    Dim fileSystemObject
    Dim textStream
    Dim fileContents As String
    Dim line As String
    Set fileSystemObject = CreateObject("Scripting.FileSystemObject")
    Set textStream = fileSystemObject.OpenTextFile(path)
    fileContents = textStream.ReadAll
    textStream.Close
    ReadInTextFile = fileContents
End Function

Sub WriteTextToFile(path As String, fileContents As String)
    Dim fileSystemObject
    Dim textStream
    Set fileSystemObject = CreateObject("Scripting.FileSystemObject")
    Set textStream = fileSystemObject.CreateTextFile(path, True)
    textStream.Write fileContents
    textStream.Close
End Sub