Public Sub ExportRangeToXML()
 
Dim strXML As String
Dim varTable As Variant
Dim intRow As Integer
Dim intCol As Integer
Dim intFileNum As Integer
Dim strFilePath As String
Dim strRowElementName As String
Dim strTableElementName As String
Dim varColumnHeaders As Variant
 
    'Set custom names
    strTableElementName = "Table"
    strRowElementName = "Row"
 
    'Set file path
    strFilePath = Application.GetSaveAsFilename(, "(*.xml),*.xml", , "Save As...")
    If strFilePath = vbNullString Then Exit Sub
 
    'Get table data
    varTable = Selection.Value
    varColumnHeaders = Selection.Rows(1).Value
 
    'Build xml
    strXML = "<?xml version=""1.0"" encoding=""utf-8""?>"
    strXML = strXML & "<" & strTableElementName & ">"
    For intRow = 2 To UBound(varTable, 1)
        strXML = strXML & "<" & strRowElementName & ">"
        For intCol = 1 To UBound(varTable, 2)
            strXML = strXML & "<" & varColumnHeaders(1, intCol) & ">" & _
                varTable(intRow, intCol) & "</" & varColumnHeaders(1, intCol) & ">"
        Next
        strXML = strXML & "</" & strRowElementName & ">"
    Next
    strXML = strXML & "</" & strTableElementName & ">"
 
 
 writeOut strXML, strFilePath
 
End Sub

Public Function writeOut(cText As String, file As String) As Integer
    On Error GoTo errHandler
    Dim fsT, tFilePath As String

    tFilePath = file + ".txt"

    'Create Stream object
    Set fsT = CreateObject("ADODB.Stream")

    'Specify stream type - we want To save text/string data.
    fsT.Type = 2

    'Specify charset For the source text data.
    fsT.Charset = "utf-8"

    'Open the stream And write binary data To the object
    fsT.Open
    fsT.writetext cText

    'Save binary data To disk
    fsT.SaveToFile tFilePath, 2

    GoTo finish

errHandler:
    MsgBox (Err.Description)
    writeOut = 0
    Exit Function

finish:
    writeOut = 1
End Function