Sub MakeXML()
' create an XML file from an Excel table
Dim MyRow As Integer, MyCol As Integer, Temp As String, YesNo As Variant, DefFolder As String
Dim XMLFileName As String, XMLRecSetName As String, MyLF As String, RTC1 As Integer
Dim RangeOne As String, RangeTwo As String, Tt As String, FldName( 99 ) As String

MyLF = Chr( 10 ) & Chr( 13 )    ' a line feed command
DefFolder = "C:\"   'change this to the location of saved XML files

YesNo = MsgBox("This procedure requires the following data:" & MyLF _
 & "1 A filename for the XML file" & MyLF _
 & "2 A groupname for an XML record" & MyLF _
 & "3 A cellrange containing fieldnames (col titles)" & MyLF _
 & "4 A cellrange containing the data table" & MyLF _
 & "Are you ready to proceed?", vbQuestion + vbYesNo, "MakeXML CiM")
 
If YesNo = vbNo Then
 Debug.Print "User aborted with 'No'"
 Exit Sub
End If

XMLFileName = FillSpaces(InputBox("1. Enter the name of the XML file:", "MakeXML CiM", "xl_xml_data"))
If Right(XMLFileName,  4 ) <> ".xml" Then
 XMLFileName = XMLFileName & ".xml"
End If

XMLRecSetName = FillSpaces(InputBox("2. Enter an identifying name of a record:", "MakeXML CiM", "record"))

RangeOne = InputBox("3. Enter the range of cells containing the field names (or column titles):", "MakeXML CiM", "A1:G1")
If MyRng(RangeOne,  1 ) <> MyRng(RangeOne,  2 ) Then
  MsgBox "Error: names must be on a single row" & MyLF & "Procedure STOPPED", vbOKOnly + vbCritical, "MakeXML CiM"
  Exit Sub
End If
MyRow = MyRng(RangeOne,  1 )
For MyCol = MyRng(RangeOne,  3 ) To MyRng(RangeOne,  4 )
 If Len(Cells(MyRow, MyCol).Value) =  0  Then
  MsgBox "Error: names range contains blank cell" & MyLF & "Procedure STOPPED", vbOKOnly + vbCritical, "MakeXML CiM"
  Exit Sub
 End If
 FldName(MyCol - MyRng(RangeOne,  3 )) = FillSpaces(Cells(MyRow, MyCol).Value)
Next MyCol

RangeTwo = InputBox("4. Enter the range of cells containing the data table:", "MakeXML CiM", "A2:G19")
If MyRng(RangeOne,  4 ) - MyRng(RangeOne,  3 ) <> MyRng(RangeTwo,  4 ) - MyRng(RangeTwo,  3 ) Then
  MsgBox "Error: number of field names <> data columns" & MyLF & "Procedure STOPPED", vbOKOnly + vbCritical, "MakeXML CiM"
  Exit Sub
End If
RTC1 = MyRng(RangeTwo,  3 )

If InStr( 1 , XMLFileName, ":\") =  0  Then
 XMLFileName = DefFolder & XMLFileName
End If

Open XMLFileName For Output As # 1 
Print # 1 , "<?xml version=" & Chr( 34 ) & "1.0" & Chr( 34 ) & " encoding=" & Chr( 34 ) & "ISO-8859-1" & Chr( 34 ) & "?>"
Print # 1 , "<meadinkent>"

For MyRow = MyRng(RangeTwo,  1 ) To MyRng(RangeTwo,  2 )
Print # 1 , "<" & XMLRecSetName & ">"
  For MyCol = RTC1 To MyRng(RangeTwo,  4 )
  ' the next line uses the FormChk function to format dates and numbers
     Print # 1 , "<" & FldName(MyCol - RTC1) & ">" & RemoveAmpersands(FormChk(MyRow, MyCol)) & "</" & FldName(MyCol - RTC1) & ">"
  ' the next line does not apply any formatting
  '  Print #1, "<" & FldName(MyCol - RTC1) & ">" & RemoveAmpersands(Cells(MyRow, MyCol).Value) & "</" & FldName(MyCol - RTC1) & ">"
    Next MyCol
 Print # 1 , "</" & XMLRecSetName & ">"

Next MyRow
Print # 1 , "</meadinkent>"
Close # 1 
MsgBox XMLFileName & " created." & MyLF & "Process finished", vbOKOnly + vbInformation, "MakeXML CiM"
Debug.Print XMLFileName & " saved"
End Sub
Function MyRng(MyRangeAsText As String, MyItem As Integer) As Integer
' analyse a range, where MyItem represents 1=TR, 2=BR, 3=LHC, 4=RHC

Dim UserRange As Range
Set UserRange = Range(MyRangeAsText)
Select Case MyItem
 Case  1 
 MyRng = UserRange.Row
 Case  2 
 MyRng = UserRange.Row + UserRange.Rows.Count -  1 
 Case  3 
 MyRng = UserRange.Column
 Case  4 
 MyRng = UserRange.Columns(UserRange.Columns.Count).Column
End Select
Exit Function

End Function
Function FillSpaces(AnyStr As String) As String
' remove any spaces and replace with underscore character
Dim MyPos As Integer
MyPos = InStr( 1 , AnyStr, " ")
Do While MyPos >  0 
 Mid(AnyStr, MyPos,  1 ) = "_"
 MyPos = InStr( 1 , AnyStr, " ")
Loop
FillSpaces = LCase(AnyStr)
End Function

Function FormChk(RowNum As Integer, ColNum As Integer) As String
' formats numeric and date cell values to comma 000's and DD MMM YY
FormChk = Cells(RowNum, ColNum).Value
If IsNumeric(Cells(RowNum, ColNum).Value) Then
 FormChk = Format(Cells(RowNum, ColNum).Value, "#,##0 ;(#,##0)")
End If
If IsDate(Cells(RowNum, ColNum).Value) Then
 FormChk = Format(Cells(RowNum, ColNum).Value, "dd mmm yy")
End If
End Function

Function RemoveAmpersands(AnyStr As String) As String
Dim MyPos As Integer
' replace Ampersands (&) with plus symbols (+)

MyPos = InStr( 1 , AnyStr, "&")
Do While MyPos >  0 
 Mid(AnyStr, MyPos,  1 ) = "+"
 MyPos = InStr( 1 , AnyStr, "&")
Loop
RemoveAmpersands = AnyStr
End Function

' This is a modified version of a script by Raymond Pang
' Note that the resulting XML is not "pretty printed"
' so you may want to view it with an XML browser or
' run it through a pretty printing tool such as xmllint
' to make it easier to read.

' GenerateXMLMacro
' @brief Relatively simple VB macro for exporting XML. Change the range, root,
         'and file name below to correspond with the portion of your document
         'that you wish to export.
' @author Edward Kmett
' @version 0.1
Sub GenerateXMLMacro()
    GenerateXML Range("A1:E19"), "example", "example.xml"
End Sub

' GenerateXML
' @brief Creates an XML document file
' @parameters rngData : The selected region on excel sheet, with the first row as field name, and data rows below
'                       For the field name, use the node delimiter "/" to build the hierarchy of data
'                       e.g. /data/field1 is equvalent to <data><field1>....</field1><data>
'
'             rootNodeName : The xml document root node tag name
'             defaultFileName : The default file name
' @author Edward Kmett
Sub GenerateXML(rngData As Range, rootNodeName As String, defaultFileName As String)
    
    ' Construct a DOM
    Set objXMLDoc = GenerateXMLDOM(rngData, rootNodeName)
    
    ' Determine the file name
    
    Dim strFile As String
    strFile = Application.GetSaveAsFilename( _
        InitialFileName:=defaultFileName, _
        FileFilter:="XML files, *.xml", _
        Title:="Save as XML")
        
    ' If a file was named then save
    If strFile = "False" Then Exit Sub
    objXMLDoc.Save strFile
End Sub

' The Source Code below this point is available in an unmodified form from:
' http://www.codeproject.com/useritems/xls2xml.asp

' GenerateXMLDOM
' @brief Generate an MS XML Object (without any format tags) based on the data inside selected region on the excel sheet
'
' @parameters rngData : The selected region on excel sheet, with the first row as field name, and data rows below
'                       For the field name, use the node delimiter "/" to build the hierarchy of data
'                       e.g. /data/field1 is equvalent to <data><field1>....</field1><data>
'
'             rootNodeName : The xml document root node tag name
'
' @return an MS XML Object
'
' @author  Raymond Pang
'
' @version 0.8

Function GenerateXMLDOM(rngData As Range, rootNodeName As String)

    Const NODE_DELIMITER As String = "/"  ' the default node delimiter
    
    Dim intColCount As Integer
    Dim intRowCount As Integer
    Dim intColCounter As Integer
    Dim intRowCounter As Integer
    
       
    Dim rngCell As Range
  
    ' Create the XML DOM object
    Set objXMLDoc = CreateObject("Microsoft.XMLDOM")
    objXMLDoc.async = False
                   
    
    ' NODE_PROCESSING_INSTRUCTION(7) --- reference http://www.devguru.com/Technologies/xmldom/quickref/obj_node.html
    ' modified (by EAK) to use UTF-8 encoding
    Set Heading = objXMLDoc.createProcessingInstruction("xml", "version=""1.0"" encoding=""UTF-8"" standalone=""yes""")
    objXMLDoc.appendChild (Heading)
    
    ' Set the root node
    Set top_node = objXMLDoc.createNode( 1 , rootNodeName, "")
    objXMLDoc.appendChild (top_node)

    Dim Nodes() As String       'Array storing the current splited node names
    Dim NodeStack() As String   'Array storing the last node names
    
    Dim new_nodes()
    ReDim NodeStack( 0 )
    ReDim new_nodes( 0 )
            
     With rngData  ' The selected region on the Excel Sheet passed in
        
        '   Discover dimensions of the data we  will be dealing with...
        intColCount = .Columns.Count
        intRowCount = .Rows.Count
        
        Dim strColNames() As String     ' The Array of column names
        ReDim strColNames(intColCount)
        
        
        ' First Row is the Field/Tag names
        ' Extract all the field names into array "strColNames"
        If intRowCount >=  1  Then
            '   Loop accross columns... and put names in array
            For intColCounter =  1  To intColCount

                '   Mark the cell under current scrutiny by setting
                '   an object variable...
                Set rngCell = .Cells( 1 , intColCounter)
                
                '  not support merged cells .. so quit
                If Not rngCell.MergeArea.Address = _
                                            rngCell.Address Then
                      MsgBox ("!! Cell Merged ... Invalid format")
                      Exit Function
                End If
                
                strColNames(intColCounter) = rngCell.Text
                                 
            Next
        End If
        
        '   Loop down the table's rows
        For intRowCounter =  2  To intRowCount
           
            ReDim new_nodes( 0 )
            ReDim NodeStack( 0 )
            '   Loop accross columns...
            For intColCounter =  1  To intColCount
                
                '   Mark the cell under current scrutiny by setting
                '   an object variable...
                Set rngCell = .Cells(intRowCounter, intColCounter)
                
                
                '   Is the cell merged?..
                If Not rngCell.MergeArea.Address = _
                                            rngCell.Address Then
                
                      MsgBox ("!! Cell Merged ... Invalid format")
                      Exit Function
                      
                                       
                End If
                          
                ' divide the field name by the delimiter to get appropriate node names
                Nodes = Split(strColNames(intColCounter), NODE_DELIMITER)
                    
                If UBound(Nodes) =  0  Then
                  ReDim Nodes( 1 )
                  Nodes( 1 ) = strColNames(intColCounter)
                End If
                
                 ' don't count it when no content
                 If Trim(rngCell.Text) <> "" Then
                                    
                    Dim I As Integer
                    MatchAll = True
                    For I =  1  To UBound(Nodes)

                        If I <= UBound(NodeStack) Then
                            
                            If Trim(Nodes(I)) <> Trim(NodeStack(I)) Then
                                'not match
                                MatchAll = False
                                Exit For
                            
                            End If
                        Else
                          MatchAll = False
                          Exit For
                        End If
                       
                                                                          
                      Next
                      
                      ' match all means in same level as previous, so it needs to output for the last node
                      If MatchAll Then
                          I = I -  1 
                      End If
                      
                          
                      If UBound(new_nodes) < UBound(Nodes) Then
                             ' enlong the array
                             ReDim Preserve new_nodes(UBound(Nodes))
                              
                              
                      End If
                          
                      For t = I To UBound(Nodes)
                          ' create uncommon nodes with the previous one
                          Set new_nodes(t) = objXMLDoc.createNode( 1 , Nodes(t), "")
                                                       
                      Next
                      
                      
                      For t = I -  1  To UBound(Nodes) -  1 
                      
                          If t >=  1  Then
                              ' connect the nodes based on the hierarchy
                              new_nodes(t).appendChild (new_nodes(t +  1 ))
                          End If
                      
                      Next
                      Set Textcont = objXMLDoc.createTextNode(Trim(rngCell.Text))
                      new_nodes(UBound(Nodes)).appendChild (Textcont)
                       
                      If I =  1  Then
                          top_node.appendChild (new_nodes( 1 ))
                      End If
                  
                  
                      NodeStack = Nodes
                                                               
                  End If
               
            Next ' finished a column
        Next
    End With
    

    '   Return the XMLDOM
     Set GenerateXMLDOM = objXMLDoc
     
End Function



' fGenerateXML
' @brief: Generate a 'clean' XML (ie. no unwanted formatting tags)
'         from an Excel range.
'
' @parameters rngData : The selected region on excel sheet, with the first row as field name, and data rows below
'                       For the field name, apart from normal
'             rootNodeName : The xml document root node tag name
'
' @return String with the content of XML preparing to write out to file
'
' @author  Raymond Pang
' @version 0.8

Function fGenerateXML(rngData As Range, rootNodeName As String) As String

'===============================================================
'   XML Tags
    '   Table
    
    Const HEADER                As String = "<?xml version=""1.0""?>"
    Dim TAG_BEGIN  As String
    Dim TAG_END  As String
    Const NODE_DELIMITER        As String = "/"
    
        
'===============================================================

    Dim intColCount As Integer
    Dim intRowCount As Integer
    Dim intColCounter As Integer
    Dim intRowCounter As Integer
    
   
    Dim rngCell As Range
 
    
    Dim strXML As String
    
       
    
    '   Initial table tag...
    
    
   TAG_BEGIN = vbCrLf & "<" & rootNodeName & ">"
   TAG_END = vbCrLf & "</" & rootNodeName & ">"
   
    strXML = HEADER
    strXML = strXML & TAG_BEGIN
                    
    With rngData
        
        '   Discover dimensions of the data we
        '   will be dealing with...
        intColCount = .Columns.Count
        
        intRowCount = .Rows.Count
        
        Dim strColNames() As String
        
        ReDim strColNames(intColCount)
        
        
        ' First Row is the Field/Tag names
        If intRowCount >=  1  Then
        
            '   Loop accross columns...
            For intColCounter =  1  To intColCount
                
                '   Mark the cell under current scrutiny by setting
                '   an object variable...
                Set rngCell = .Cells( 1 , intColCounter)
                
              
                
                '   Is the cell merged?..
                If Not rngCell.MergeArea.Address = _
                                            rngCell.Address Then
               
                      MsgBox ("!! Cell Merged ... Invalid format")
                      Exit Function
                      
                                       
                End If
            
                 strColNames(intColCounter) = rngCell.Text
                
            Next
        
        End If
        
        
        Dim Nodes() As String
        Dim NodeStack() As String
      
      
        '   Loop down the table's rows
        For intRowCounter =  2  To intRowCount
           
            
            strXML = strXML & vbCrLf & TABLE_ROW
            ReDim NodeStack( 0 )
            '   Loop accross columns...
            For intColCounter =  1  To intColCount
                
                '   Mark the cell under current scrutiny by setting
                '   an object variable...
                Set rngCell = .Cells(intRowCounter, intColCounter)
                
                               
                '   Is the cell merged?..
                If Not rngCell.MergeArea.Address = _
                                            rngCell.Address Then
                
                      MsgBox ("!! Cell Merged ... Invalid format")
                      Exit Function
                      
                End If
               
                If Left(strColNames(intColCounter),  1 ) = NODE_DELIMITER Then
                      
                      Nodes = Split(strColNames(intColCounter), NODE_DELIMITER)
                          ' check whether we are starting a new node or not
                          Dim I As Integer
                         
                          Dim MatchAll As Boolean
                          MatchAll = True
                         
                          
                          For I =  1  To UBound(Nodes)
    
                              If I <= UBound(NodeStack) Then
                                  
                                  If Trim(Nodes(I)) <> Trim(NodeStack(I)) Then
                                      'not match
                                      'MsgBox (Nodes(i) & "," & NodeStack(i))
                                      MatchAll = False
                                      Exit For
                                  
                                  End If
                              Else
                                MatchAll = False
                                Exit For
                              End If
                              
                              
                                                                                
                          Next
                          
                          ' add close tags to those not used afterwards
                          
              
                         ' don't count it when no content
                         If Trim(rngCell.Text) <> "" Then
                            
                            If MatchAll Then
                              strXML = strXML & "</" & NodeStack(UBound(NodeStack)) & ">" & vbCrLf
                            Else
                              For t = UBound(NodeStack) To I Step - 1 
                                strXML = strXML & "</" & NodeStack(t) & ">" & vbCrLf
                              Next
                            End If
                            
                            If I < UBound(Nodes) Then
                                For t = I To UBound(Nodes)
                                    ' add to the xml
                                    strXML = strXML & "<" & Nodes(t) & ">"
                                    If t = UBound(Nodes) Then
                                                                           
                                            strXML = strXML & Trim(rngCell.Text)
                                        
                                    End If
                                    
                                Next
                              Else
                                  t = UBound(Nodes)
                                  ' add to the xml
                                  strXML = strXML & "<" & Nodes(t) & ">"
                                  strXML = strXML & Trim(rngCell.Text)

                              End If
                           
                              NodeStack = Nodes
                           
                          Else
                          
                            ' since its a blank field, so no need to handle if field name repeated
                            If Not MatchAll Then
                              For t = UBound(NodeStack) To I Step - 1 
                                strXML = strXML & "</" & Trim(NodeStack(t)) & ">" & vbCrLf
                              Next
                            End If
                            
                            ReDim Preserve NodeStack(I -  1 )
                          End If
                            
                                              
                          ' the last column
                          If intColCounter = intColCount Then
                           ' add close tags to those not used afterwards
                              If UBound(NodeStack) <>  0  Then
                               For t = UBound(NodeStack) To  1  Step - 1 
                          
                              strXML = strXML & "</" & Trim(NodeStack(t)) & ">" & vbCrLf
                              
                              Next
                              End If
                          End If
                   
                 Else
                      ' add close tags to those not used afterwards
                      If UBound(NodeStack) <>  0  Then
                          For t = UBound(NodeStack) To  1  Step - 1 
                          
                           strXML = strXML & "</" & Trim(NodeStack(t)) & ">" & vbCrLf
                              
                          Next
                      End If
                      ReDim NodeStack( 0 )
      
                        ' skip if no content
                      If Trim(rngCell.Text) <> "" Then
                        strXML = strXML & "<" & Trim(strColNames(intColCounter)) & ">" & Trim(rngCell.Text) & "</" & Trim(strColNames(intColCounter)) & ">" & vbCrLf
                      End If
                      
                  End If
                
                    
                
                
            Next
           
        Next
    End With
    
    strXML = strXML & TAG_END
    
    '   Return the HTML string...
    fGenerateXML = strXML
    
End Function



' Function for writing plain string out a file

Sub sWriteFile(strXML As String, strFullFileName As String)

    Dim intFileNum As String
    
    intFileNum = FreeFile
    Open strFullFileName For Output As #intFileNum
    Print #intFileNum, strXML
    Close #intFileNum
    
    
End Sub

' To automatically select the "REAL"/non empty continuous regions (rows and columns)

Sub FindUsedRange()
    Dim LastRow As Long
    Dim FirstRow As Long
    Dim LastCol As Integer
    Dim FirstCol As Integer

    ' Find the FIRST real row
    FirstRow = ActiveSheet.Cells.Find(What:="*", _
      SearchDirection:=xlNext, _
      SearchOrder:=xlByRows).Row
      
    ' Find the FIRST real column
    FirstCol = ActiveSheet.Cells.Find(What:="*", _
      SearchDirection:=xlNext, _
      SearchOrder:=xlByColumns).Column
    
    ' Find the LAST real row
    LastRow = ActiveSheet.Cells.Find(What:="*", _
      SearchDirection:=xlPrevious, _
      SearchOrder:=xlByRows).Row

    ' Find the LAST real column
    LastCol = ActiveSheet.Cells.Find(What:="*", _
      SearchDirection:=xlPrevious, _
      SearchOrder:=xlByColumns).Column
        
'Select the ACTUAL Used Range as identified by the
'variables identified above
    'MsgBox (FirstRow & "," & LastRow & "," & FirstCol & "," & LastCol)
    Dim topCel As Range
    Dim bottomCel As Range
   
    Set topCel = Cells(FirstRow, FirstCol)
    Set bottomCel = Cells(LastRow, LastCol)
    
   ActiveSheet.Range(topCel, bottomCel).Select
End Sub