Converting single row in excel to XML document using VBA

[skapunkboy]

Hi All

I am after some help

I have been asked if I can convert a spreadsheet that will have a variable number of rows into single XML files for ordering

here is a basic example of my data

Name	Brand	Quantity	Unique Code
Mr Why	Generic Ale	2	XML00001
Mr Who	Generic Lager	4	XML00002

<tbody>
</tbody>

So far I have done a bit of searching but I would really like to understand the code rather than just borrowing from the internet

here is what I have thus far to loop through each row and drop it onto a separate tab followed by creating the XML files

Sub XLM_Generation()




Sheet1.Activate


For Each DATA_ROW In Sheet1.Range(Cells(2, "A"), Cells(ActiveSheet.UsedRange.Rows.Count, "A"))


DATA_ROW.EntireRow.Copy


Sheet2.Activate
Sheet2.Range("A2").PasteSpecial


Set XML_DOC = CreateObject("MSXML2.DOMDocument")
XML_DOC.async = False
XML_DOC.validateOnParse = False
XML_DOC.resolveExternals = False


Dim XML_DATA As String


XML_DATA = "<?xml version=""1.0"" encoding=""ISO-8859-1""?>" & vbNewLine
XML_DATA = XML_DATA & "<RECORD>" & vbNewLine






For Each CELL In Sheet2.Range("A2:D2")
If CELL.Value = "" Then GoTo NO_DATA


XML_DATA = XML_DATA & "<" & CELL.Offset(-1, 0).Value & ">"
XML_DATA = XML_DATA & CELL.Value
XML_DATA = XML_DATA & "</" & CELL.Offset(-1, 0).Value & ">" & vbNewLine
GoTo DATA


NO_DATA:
XML_DATA = XML_DATA & "<" & CELL.Offset(-1, 0).Value & "/>" & vbNewLine


DATA:


Next


XML_DATA = XML_DATA & "</RECORD>"




XML_DOC.LoadXML XML_DATA


XML_DOC.Save "\XML TEST" & Sheet2.Range("D2").Value & ".XML"




Next




End Sub

This work at creating the right XML data as I did get it to paste into a spare column to check if what I was doing was correct

It also creates the XML files in the folder I wanted but they are blank

Any help would be really appreciated

I need to be able to vary the rows and columns because the document may change with different lines introduced for ordering

thank you in advance

 

[Domenic]

The reason why you're getting a blank file is that you're actually getting an error when you try to load your XML data. That's because you need at least one root or top element in an XML file. You can test it for yourself by using the following lines of code instead to load the data...

    If Not XML_DOC.LoadXML(xmlData) Then
        With XML_DOC.parseError
            MsgBox "Error: " & .ErrorCode & vbCrLf & .reason, vbCritical, "Error"
            Exit Sub
        End With
    End If

However, once you've added a root element, you'll also get another error since tag names should not contain spaces. So you'll need to make sure that your column headers don't contain any spaces. So, for example, in your sample data, you'll need to replace "Unique Code" with "UniqueCode".


Lastly, since it looks like you don't need to read or manipulate the XML document, you can use the Open statement to create your XML file instead of the MSXML2.DOMDocument object. In any case, I'll provide you with the code for both methods.


Note: To prevent this Board from interpreting the code as HTML code, a space has been added after each occurrence of a left angled bracket (<). Therefore, remove these spaces from the code.


Using the MSXML2.DOMDocument Object

Option Explicit


Sub XML_Generation()


    Dim sourceData As Range
    Set sourceData = Sheet2.Range("A1").CurrentRegion
    
    Dim xmlData As String
    Dim rowIndex As Long
    Dim colIndex As Long
    xmlData = ""
    For rowIndex = 2 To sourceData.Rows.Count
        For colIndex = 1 To sourceData.Columns.Count
            xmlData = xmlData & vbTab & "< " & sourceData(1, colIndex).Value & ">"
            xmlData = xmlData & sourceData(rowIndex, colIndex).Value
            xmlData = xmlData & "< /" & sourceData(1, colIndex).Value & ">"
            xmlData = xmlData & vbCrLf
        Next colIndex
    Next rowIndex
    
    'add a root element
    xmlData = "< list>" & vbCrLf & xmlData & "< /list>"
    
    Dim xmlDoc As Object
    Set xmlDoc = CreateObject("MSXML2.DOMDocument")
    With xmlDoc
        .async = False
        .validateOnParse = False
        .resolveExternals = False
    End With
    
    If Not xmlDoc.LoadXML(xmlData) Then
        With xmlDoc.parseError
            MsgBox "Error: " & .ErrorCode & vbCrLf & .reason, vbCritical, "Error"
            Exit Sub
        End With
    End If
    
    xmlDoc.Save "c:\users\domenic\desktop\sample.xml" 'change the path and filename accordingly
    
    MsgBox "XML file created and saved.", vbInformation
    
End Sub

Using the Open Statement

Option Explicit


Sub XML_Generation2()


    Dim sourceData As Range
    Set sourceData = Sheet2.Range("A1").CurrentRegion
    
    Dim xmlData As String
    Dim rowIndex As Long
    Dim colIndex As Long
    xmlData = ""
    For rowIndex = 2 To sourceData.Rows.Count
        For colIndex = 1 To sourceData.Columns.Count
            xmlData = xmlData & vbTab & "< " & sourceData(1, colIndex).Value & ">"
            xmlData = xmlData & sourceData(rowIndex, colIndex).Value
            xmlData = xmlData & "< /" & sourceData(1, colIndex).Value & ">"
            xmlData = xmlData & vbCrLf
        Next colIndex
    Next rowIndex
    
    'add a root element
    xmlData = "< list>" & vbCrLf & xmlData & "< /list>"
    
    Dim fileNum As Long
    fileNum = FreeFile()
    
    Dim destFile As String
    destFile = "c:\users\domenic\desktop\sample2.xml" 'change the path and filename accordingly
    
    Open destFile For Output As [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=fileNum"]#fileNum[/URL] 
        Print [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=fileNum"]#fileNum[/URL] , xmlData
    Close [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=fileNum"]#fileNum[/URL] 
    
    MsgBox "XML file created and saved.", vbInformation
    
End Sub

Hope this helps!

 

[Domenic]

Just a slight amendment to the code so that you won't have to worry about removing spaces from your column headers. The following changes in red will replace any spaces with an underscore (_).

    For rowIndex = 2 To sourceData.Rows.Count
        For colIndex = 1 To sourceData.Columns.Count
            xmlData = xmlData & vbTab & "<" & [COLOR=#ff0000]Replace(sourceData(1, colIndex).Value, " ", "_")[/COLOR] & ">"
            xmlData = xmlData & sourceData(rowIndex, colIndex).Value
            xmlData = xmlData & "<!--" & <font color="#ff0000"-->Replace(sourceData(1, colIndex).Value, " ", "_") & ">"
            xmlData = xmlData & vbCrLf
        Next colIndex
    Next rowIndex

If you prefer, you can remove the space without replacing it with anything...

Replace(sourceData(1, colIndex).Value, " ", "")

 

[skapunkboy]

Dominic thank you so much

This works perfectly and I will get to work making sure everything kicks out the way we want it.

I also now understand a lot more about XML

 

[Domenic]

You're very welcome. I'm glad I could help.

And thanks for your feedback.

Cheers!

 

[abhayshrivatava]

I need some help on the same line. I dont have much coding background. I need to convert excel row data into separate XML files with .txt extension using MACRO or VBA, not excel schema. I have a lot of sheets with different tagnames to convert, so I need a generic script. Attached is the sample screenshot of the data. And that goes upto cell BS. Please help. A quick help is needed. Thanks a lot in advance.