From Excel to XML via VBA

[makikivi]

Hello,

I am trying to get an XML out of an excel 2007 file using VBA code. I wanted to attach the file but I cannot because I dont have 5 thread posts so far :). What it does is, it converts the table into a row-column structure in XML. And as a result I get the following:

<?xml version="1.0" ?>
<data>
<one>
<row>
<column>Raymond</column>
<column>11</column>
<column>59</column>
</row>
</one>
<one>
<row>
<column>Moon</column>
<column>7456</column>
<column>58</column>
</row>

However, I need each of the rows to have its own name attribute, like the following:

<?xml version="1.0" ?>
<data>
<one name="Proj1">
<row>
<column>Raymond</column>
<column>11</column>
<column>59</column>
</row>
</one>
<one name="Proj2">
<row>
<column>Moon</column>
<column>7456</column>
<column>58</column>
</row>

Can someone help me in resolving this small issue? If you want the code please give me your e-mail and I will send it to you. THANK YOU

[Bob Phillips]

We might be able to help resolve the issue if we had any idea what the issue was.

[makikivi]

Well, the code that I have produces this as a result:

<?xml version="1.0" ?>
<data>
<one>
<row>
<column>Raymond</column>
<column>11</column>
<column>59</column>
</row>
</one>
<one>
<row>
<column>Moon</column>
<column>7456</column>
<column>58</column>
</row>

And I want to adjust the code so I can get this as a result:

<?xml version="1.0" ?>
<data>
<one name="Proj1">
<row>
<column>Raymond</column>
<column>11</column>
<column>59</column>
</row>
</one>
<one name="Proj2">
<row>
<column>Moon</column>
<column>7456</column>
<column>58</column>
</row>

And this is the code that I use:

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


Set Heading = ObjXMLDoc.createNode(7, "xml", "")
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