Converting single row in excel to XML document using VBA

skapunkboy

New Member
Joined
Apr 29, 2015
Messages
8
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

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Name[/TD]
[TD]Brand[/TD]
[TD]Quantity[/TD]
[TD]Unique Code[/TD]
[/TR]
[TR]
[TD]Mr Why[/TD]
[TD]Generic Ale[/TD]
[TD]2[/TD]
[TD]XML00001[/TD]
[/TR]
[TR]
[TD]Mr Who[/TD]
[TD]Generic Lager[/TD]
[TD]4[/TD]
[TD]XML00002[/TD]
[/TR]
</tbody>[/TABLE]

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
 

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.
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...


Code:
    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


Code:
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


Code:
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!
 
Last edited:
Upvote 0
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 (_).

Code:
    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...

Code:
Replace(sourceData(1, colIndex).Value, " ", "")
 
Upvote 0
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
 
Upvote 0
You're very welcome. I'm glad I could help.

And thanks for your feedback.

Cheers!
 
Upvote 0
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.
 

Attachments

  • Capture.PNG
    Capture.PNG
    123 KB · Views: 81
Upvote 0

Forum statistics

Threads
1,223,893
Messages
6,175,248
Members
452,623
Latest member
cliftonhandyman

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top