Solved: Parse XML Attributes with Excel VBA

[brorick]

I am currently working on a project that requires me to export an excel spreadsheet to an xml file. I feel comfortable I could parse out normal column headers. I am not sure how to handle xml tag attributes. For instance in my example below the attribute I am referring to would be the yearID and monthID within the cal tag. I would of course want to accomplish this in VBA.

I thought I could have a popup window prompt me for the firstchild tag and then for any associated attributes. The code would then paste the associated attributes column header and value within the firstchild tag and so fourth. Any recommendations would be great. The xml example below would be the end result. Thanks in advance.

The columns within excel would be

a1 = cal/@yearID
b1 = cal/@monthID
c1 = date/@id
d1 = msg

I would of course have to consider the possibility in the future a tag with an attribute might also contain a nodevalue.

<?xml version="1.0"?>
<diary>
<cal yearID="2002" monthID="0">
<date id="1">
<msg>Shailendra's birthday</msg>
</date>
<date id="17">
<msg>Appointment with the dentist at 4:30</msg>
</date>
<date id="18">
<msg>Call Brainvisa Technologies. Speak to Mr. Amit Garg. Phone number 5890946/47</msg>
</date>
<date id="25">
<msg>Fix an appoitment with the dentist.</msg>
</date>
</cal>
</diary>

[Ken Puls]

Well, I know absolutely no XML, but I'll give it a shot if you're just trying to read data and convert it into the correct tag format. You'll need to tell me if I miss something.

I assume that you're trying to set up a loop to populate the following portions?
<date id="1">
<msg>Shailendra's birthday</msg>
</date>
with each date, yes?

Can you upload a sample sheet of data, as I'm not quite confident that I understand the layout.

Also, the "date id" tag... Is it the number of days since the start of the year? Is that why the monthID tag is 0 in the Cal line?

[CBrine]

I was doing some investigation of XML a few months back. We ended up not using it, but I did find an addin from Microsoft for working with XML files. It was from the msdn site, just not sure exactly where. Might be something to look into though.

HTH
Cal

[mvidas]

Brorick,
I thought Excel had a SaveAs type of xml, at least in later versions.
Regardless.. based on your example above (and some variations I created), I was able to create something to export as you describe. I assumed your worksheet was named 'diary', your 1st row contained the tags and attributes as described in your first post, and each subsequent row contained the data for that tag/attribute. So if I had to put your test data above into CSV format, it would be:

cal/@yearID,cal/@monthID,date/@id,msg
2002,0,1,Shailendra's birthday
2002,0,17,Appointment with the dentist at 4:30
2002,0,18,Call Brainvisa Technologies. Speak to Mr. Amit Garg. Phone number 5890946/47

Is that how your sheet looks? Assuming it does, run the following "ExportForBrorick" subroutine, changing the output xml file and sheet to export as needed:'See my code later in the threadPlease let me know if I misinterpreted you, or you have any questions.
Matt

[brettdj]

Matt,

Without testing this yet I'm impressed

Did you consider a regex for this - I was but didn't get around to it

Cheers

Dave

[mvidas]

Did you consider a regex for this - I was but didn't get around to itI did have it for a little while, to pull the tags and attributes from the header row. But I realized that there wasn't really a good reason to have it, since I was only concerned if there was a "/@" in it. Because of that, and because I only had to get the tags once, I decided to just stick with instr.

Its funny.. this question indirectly caused the demise of my laptop :( I guess that really isnt funny, but I was working on code for this question (not 5 minutes after the last PM I sent you Friday) when I must have bumped the ac adapter wrong or something. gonna have to replace the motherboard on the laptop I think, something I've never done before. This question also indirectly caused me to finally hook my old pc to my tv, as the monitor I had for it was sub-par and I'd been meaning to hook it up to my tv anyways, so at least some good came of the broken laptop. i hope i can get it working back to normal, I just updated malcolms outlook code about the notifications and I wanted to share here. soon enough, hopefully

[Ken Puls]

Yikes! Hopefully you've got a warranty on the laptop. That always makes it easier. What brand do you use, if you don't mind my asking?

[mvidas]

There was a warranty on it but it expired a little over a month ago (go figure). Its a toshiba, was the best buy black friday laptop in 2004, $499. This isn't the first problem I've had with the power, just the last one. At one point over this past summer it fell, and the power cable had a couple issues after that. they went away for a while, but a couple weeks ago it started acting up (the laptop would suddenly think nothing was plugged in until i jiggled the cord a little. I think I could fix it without replacing the MB but I'm told its safer and overall better to get the mb too. havent looked too far into it yet though, i'm sure i'll have another rant on here at some point once I get it done :P

[tlm2740]

I also was asked to take data from a spreadsheet and turn it into an XML file for viewing. The first thing I would caution you on is that XML will choke if you use its' special characters (&, <, >, " and ') for which I have not found the best way to handle yet.

What I did was created a macro that creates the XML file, see below:

Sub MakeXML()
Dim PageName, MemType As String
Dim Ycell, Xcell As Integer
PageName = "C:\" & ActiveSheet.Cells(2, 2).Value & ".xml" 'location and name of saved file
Open PageName For Output As #1
Print #1, "<?xml version=" & Chr(34); "1.0" & Chr(34); " encoding=" & Chr(34); "ISO-8859-1" & Chr(34); "?>"
Print #1, "<?xml-stylesheet type=" & Chr(34); "text/xsl" & Chr(34); " href=" & Chr(34); Chr(46); Chr(46); "/XML/TOOLdraft.xsl" & Chr(34); "?>"
Print #1, "<TOOLdraft>"
Print #1, "<title>"; ActiveSheet.Cells(2, 2).Value; "</title>"
Print #1, "<!-- ###### VERSION ###### -->"
Print #1, "<version>"
Print #1, "<versionNum>"; ActiveSheet.Cells(3, 2).Value; "</versionNum>"
Print #1, "<versionDescrip>"; ActiveSheet.Cells(4, 2).Value; "</versionDescrip>"
Print #1, "<versionDate>"; ActiveSheet.Cells(5, 2).Value; "</versionDate>"
Print #1, "<versionAuthor>"; ActiveSheet.Cells(6, 2).Value; "</versionAuthor>"
Print #1, "<versionContent>"
Print #1, "<!-- ###### ORDERSET PROTOTYPE ###### -->"
Print #1, "<orderset>"
Print #1, "<moduleName>"; ActiveSheet.Cells(8, 2).Value; "</moduleName>"
Print #1, "<moduleDescrip>"; ActiveSheet.Cells(7, 2).Value; "</moduleDescrip>"
Xcell = 2
Do Until IsEmpty(ActiveSheet.Cells(9, Xcell))
Print #1, "<alias>"; LCase(ActiveSheet.Cells(9, Xcell).Value); "</alias>"
Xcell = Xcell + 1
Loop
Print #1, "<ordersetContent>"
Print #1, "<spacer/>"
Print #1, "<!-- ###### Orderable within an orderset ###### -->"
Xcell = 11
Do Until IsEmpty(ActiveSheet.Cells(Xcell, 2))
Select Case ActiveSheet.Cells(Xcell, 1).Value
Case "Orderable"
MemType = "OR"
If IsEmpty(ActiveSheet.Cells(Xcell, 3)) Then
Print #1, "<choice type=" & Chr(34); MemType; Chr(34); ">"; LCase(ActiveSheet.Cells(Xcell, 2).Value); "</choice>"
Else
Print #1, "<linked type=" & Chr(34); MemType; Chr(34); ">"; LCase(ActiveSheet.Cells(Xcell, 2).Value); "</linked>"
End If
Case "Outline"
MemType = "OS"
Print #1, "<choice type=" & Chr(34); MemType; Chr(34); ">"; LCase(ActiveSheet.Cells(Xcell, 2).Value); "</choice>"
Case "iChoice"
MemType = "IC"
Print #1, "<choice type=" & Chr(34); MemType; Chr(34); ">"; LCase(ActiveSheet.Cells(Xcell, 2).Value); "</choice>"
Case "iLink"
MemType = "IL"
Print #1, "<choice type=" & Chr(34); MemType; Chr(34); ">"; LCase(ActiveSheet.Cells(Xcell, 2).Value); "</choice>"
Case "iForm"
MemType = "IF"
Print #1, "<choice type=" & Chr(34); MemType; Chr(34); ">"; LCase(ActiveSheet.Cells(Xcell, 2).Value); "</choice>"
Case "Spacer"
Print #1, "<spacer/>"
Case "Remark"
Print #1, "<remark>"; LCase(ActiveSheet.Cells(Xcell, 2).Value); "</remark>"
End Select
Xcell = Xcell + 1
Loop

Print #1, "<spacer/>"
Print #1, "</ordersetContent>"
Print #1, "</orderset>"
Print #1, "</versionContent>"
Print #1, "</version>"
Print #1, "</TOOLdraft>"
ActiveWorkbook.FollowHyperlink Address:=PageName, NewWindow:=True '

Close #1
End Sub

It is still a work in progress, but I am at least getting the output I need.

[stanl]

I'm coming in late on this thread, but in my experience there are 3 possibilities with Excel/XML parsing.

1. Excel 2003 does support an XML export but it is arcane and probably more for Web apps.

2. The XMLDom can create and parse well-formed XML (there is also a freeware control from Chilkat that performs in less memory)

3. If you treat your Excel sheet or range as an ADO recordset, when issuing oRS.Save() you can persist to an XML recordset (sometimes referred to as a z:row since all columns are treated as attributes. You can bypass the arcane-ness of #1 by treating a sheet as a range and exporting with a different constant.

of course you can always create code to output to a text file, which is tedious and non-generic.

post a sample sheet and I can provide code for 1 or more options.

.02

Stan

[brorick]

I want to thank everyone for helping me tackle this challenge. I have had the opportunity to only try the first example by MVIDAS at this time. It is an excellent example. I want to thank MVIDAS and everyone else for their time and effort. Awesome!

[mvidas]

Glad it worked out for you! If you need to add/subtract any tags/attributes, just follow the same format you explained above. Any value in row 1 will be treated as a tag, and if it has /@ in it, then there will be that attribute associated with the tag. I only had tags combine if they're next to each other, so if your first row looked like:

a1 = cal/@yearID
b1 = cal/@monthID
c1 = date/@id
d1 = cal/@monthName
e1 = msg

Then you would never see a line in your xml file of
<cal yearID="2002" monthID="0" monthName="Jan">

You'd instead see
<cal yearID="2002" monthID="0">
and
<cal monthName="Jan">
separately.

Let us know if you need anything else! If you're all set with this, you can close it by going to Thread Tools near the top of the page, and selecting "Mark Thread Solved" :)

Matt

[brorick]

Hello MVIDAS,

I had a quick question. I added two new columns to my Excel spreadsheet. The followup/@id and the contactname. The close tag for the followup/@id tag in XML is falling between the next main cal tag.

I have attached the spreadsheet and the XML file. Any suggestions? Thanks in advance. I just got your reply as I was writing this post. I think this is different. Please forgive me if I am wrong.

[mvidas]

I think I understand, change the BrorickParseXML function toFunction BrorickParseXML(ByVal WS As Worksheet) As String()
'See my code later in the thread
End FunctionHopefully that'll take care of it.
Matt

[brorick]

Thank you. I will give it a try.

[brorick]

I get an error, "GetTags is not defined". I currently looking over the code to resolve the issue. Thanks.

[mvidas]

It sounds like you pasted my function above over both the BrorickParseXML function and the GetTags function. Just undo your paste, or re-copy the GetTags function above..

[brorick]

You are correct. I did paste over the code. The code has been correctly added.

It appears to me when I run it that all of the closing tags after the first one are listed correctly(This is great.). Unfortunately, the first cal, date and followup closing tags appear at the very end. I have included a copy. Thanks.

[mvidas]

I didn't think about that, nor did I see it on any of the 5 files I exported (wasnt looking either..:))

Right near the end of the BrorickParseXML function there is a 'For j ...' loop.. comment this out' For j = TagCnt To 0 Step -1
' If UBound(Tags(j)) > 0 Then
' ReDim Preserve XMLData(Cnt)
' XMLData(Cnt) = "</" & Tags(j)(0) & ">"
' Cnt = Cnt + 1
' End If
' NextThat is what is adding the double tags at the end. Sorry about all this!
Matt

[brorick]

Thanks again for your help and sticking with it. I will give it a try.

[brorick]

I checked it and it did resolve the tags at the end of the XML document, but it did not place the closing tags on the very first cal, date and followup tags. Sorry.

[mvidas]

I see what you mean.. I'll be busy with my actual work for a while today, but I'll take a look at this later on and definately come up with an answer for you. In the meantime if you need it sooner, you may want to try one of the other options above, since I won't really have time for a few hours for this..
Matt

[brorick]

I am in the same boat. My day will be a busy one. I won't get the opportunity to look any closer at the code until later in the day. Whenever you get to it works for me too. Thanks again for all of your help.

[mvidas]

Actually I got it all set, with the exception of one thing I need clarification on.

In the sample file you posted, the last two items both have a followupid of Yes.

In cases like this, do you want the data to look like:
<cal yearID="2005" monthID="1">
<date id="3">
<msg>Parent Anniversary</msg>
<followup id="Yes">
<contactname>Tom</contactname>
</date>
</cal>
<cal yearID="2005" monthID="2">
<date id="13">
<msg>Satish's Birthday</msg>
<contactname>Mary</contactname>
</followup>
</date>
</cal>Or do you want it to look like:
<cal yearID="2005" monthID="1">
<date id="3">
<msg>Parent Anniversary</msg>
<followup id="Yes">
<contactname>Tom</contactname>
</followup>
</date>
</cal>
<cal yearID="2005" monthID="2">
<date id="13">
<msg>Satish's Birthday</msg>
<contactname>Mary</contactname>
</date>
</cal>As you may be able to see, the difference is where the "</followup>" line goes.. once I get the answer to this (or even a third alternative), I'll give you the code.
Matt

[brorick]

The second example is the perfect layout with the exception I added the missing followup id tag for the second record. Here is the example.

<cal yearID="2005" monthID="1">
<date id="3">
<msg>Parent Anniversary</msg>
<followup id="Yes">
<contactname>Tom</contactname>
</followup>
</date>
</cal>
<cal yearID="2005" monthID="2">
<date id="13">
<msg>Satish's Birthday</msg>
<followup id="Yes">
<contactname>Mary</contactname>
</followup>
</date>
</cal>

I was wondering would it be easier to identify the order of the tag within the column header or would it be best to maintain the order from left to right? Here is an example of identify the order of the tag in the column header.

cal/@yearID
cal/@monthID
cal/date/@id
cal/date/msg
cal/date/followup/@id
cal/date/followup/contactname
cal/date/status/@id
cal/date/status/updatedby

This would result in the following XML layout.

<cal yearID="2005" monthID="1">
<date id="3">
<msg>Parent Anniversary</msg>
<followup id="Yes">
<contactname>Tom</contactname>
</followup>
<status id="complete">
<updatedby>Richard</updatedby>
</status>
</date>
</cal>

I hope this does not complicate the process. I was just wondering. Thanks.

[mvidas]

Currently it uses the left-to-right as the order it enters information, then right-to-left as it is closing tags. It only closes the tag if different than the entry after it (which is where this issue is coming up now). I'm trying to figure out how I should program the logic that says "close followup tag at each record even if it doesnt change, but only close cal tag when it changes".

What it does is first parse the sheet into an array that resembles this (in CSV form):

<edited by mvidas .. worthless text and waste of bandwidth>

Though I just had a thought of what else I can do.. I'll get back to you again

[mvidas]

OK!
I think I have it (again).

Give this a try, when you get a chance. This is the full code, so you can replace what you currently have with this. Only the BrorickParseXML function changed, as far as I remember, but I wanted to paste the whole thing for continuity sake. I deleted my code above, as it was taking up a lot of room.Sub ExportForBrorick()
'http://vbaexpress.com/forum/showthread.php?t=6620
Dim XMLArray() As String, vFF As Long, vFile As String, i As Long

vFile = "C:\diary.xml" 'file to export to
XMLArray = BrorickParseXML(ThisWorkbook.Sheets("diary")) 'send sheet to export

vFF = FreeFile
Open vFile For Output As #vFF
For i = 0 To UBound(XMLArray)
Print #vFF, XMLArray(i)
Next
Close #vFF
MsgBox "Done! " & vFile & " created!"
End Sub
Function BrorickParseXML(ByVal WS As Worksheet) As String()
Dim HeadRG As Range, DataRG As Range, CLL As Range, LRow As Range
Dim Tags(), TagCnt As Long, XMLData() As String, TempStr As String
Dim i As Long, j As Long, k As Long, Cnt As Long, TagFlag As Boolean
Dim tArr() As String
Set HeadRG = WS.Range("A1", WS.Cells(1, Columns.Count).End(xlToLeft))
Tags = GetTags(HeadRG)
TagCnt = UBound(Tags)
Set LRow = WS.Cells.Find("*", LookIn:=-4163, SearchOrder:=1, SearchDirection:=2)
Set DataRG = WS.Range("A2", WS.Cells(LRow.Row, 1))
Cnt = 0
ReDim tArr(TagCnt, 0)
For Each CLL In DataRG.Cells
ReDim Preserve tArr(TagCnt, Cnt)
k = 0
For i = 0 To TagCnt
TempStr = "<" & Tags(i)(0)
If UBound(Tags(i)) > 0 Then
For j = 1 To UBound(Tags(i))
TempStr = TempStr & " " & Tags(i)(j) & "=""" & CLL.Offset(0, _
k + j - 1).Text & """"
Next 'j
k = k + UBound(Tags(i)) - 1
Else
TempStr = TempStr & ">" & CLL.Offset(0, k).Text & "</" & Tags(i)(0)
End If
TempStr = TempStr & ">"
k = k + 1
tArr(i, Cnt) = TempStr
Next 'i
Cnt = Cnt + 1
Next 'CLL
ReDim XMLData(1)
XMLData(0) = "<?xml version=""1.0""?>"
XMLData(1) = "<" & WS.Name & ">"
Cnt = 2
For i = 0 To UBound(tArr, 2)
For j = 0 To TagCnt
TagFlag = False
If i > 0 Then
For k = 0 To j
If tArr(k, i) <> tArr(k, i - 1) Then
TagFlag = True
Exit For
End If
Next
Else
TagFlag = True
End If
If TagFlag Then
ReDim Preserve XMLData(Cnt)
XMLData(Cnt) = tArr(j, i)
Cnt = Cnt + 1
End If
Next
For j = TagCnt To 0 Step -1
If i < UBound(tArr, 2) And UBound(Tags(j)) > 0 Then
TagFlag = False
For k = j To 0 Step -1
If tArr(k, i) <> tArr(k, i + 1) Then
TagFlag = True
Exit For
End If
Next k
If TagFlag Then
ReDim Preserve XMLData(Cnt)
XMLData(Cnt) = "</" & Tags(j)(0) & ">"
Cnt = Cnt + 1
End If
End If
Next
Next
For j = TagCnt To 0 Step -1
If UBound(Tags(j)) > 0 Then
ReDim Preserve XMLData(Cnt)
XMLData(Cnt) = "</" & Tags(j)(0) & ">"
Cnt = Cnt + 1
End If
Next
ReDim Preserve XMLData(Cnt)
XMLData(Cnt) = "</" & WS.Name & ">"
BrorickParseXML = XMLData
End Function
Function GetTags(ByVal TagRange As Range) As Variant()
Dim TagArr(), Cnt As Long, tArr() As String, tCnt As Long, TempArr()
Dim CLL As Range, iPos As Long
ReDim TempArr(TagRange.Cells.Count - 1)
tCnt = 0
For Each CLL In TagRange.Cells
iPos = InStr(1, CLL.Text, "/@")
If iPos > 0 Then
ReDim tArr(1)
tArr(0) = Left$(CLL.Text, iPos - 1)
tArr(1) = Mid$(CLL.Text, iPos + 2)
Else
ReDim tArr(0)
tArr(0) = CLL.Text
End If
TempArr(tCnt) = tArr
tCnt = tCnt + 1
Next
ReDim TagArr(0)
For tCnt = 0 To TagRange.Cells.Count - 1
If tCnt > 0 Then
If TempArr(tCnt)(0) = TempArr(tCnt - 1)(0) Then 'same tag, new attribute
tArr = TagArr(Cnt - 1)
ReDim Preserve tArr(UBound(tArr) + 1)
tArr(UBound(tArr)) = TempArr(tCnt)(1)
TagArr(Cnt - 1) = tArr
Else 'new tag
ReDim Preserve TagArr(Cnt)
TagArr(Cnt) = TempArr(tCnt)
Cnt = Cnt + 1
End If
Else 'new tag
ReDim Preserve TagArr(Cnt)
TagArr(Cnt) = TempArr(tCnt)
Cnt = Cnt + 1
End If
Next
GetTags = TagArr
End FunctionMatt

[brorick]

It looks great. I will give it a try. Thanks.

[brorick]

Matt, it worked like a charm. I have tested it with different scenarios and each performed excellently. You are the king! Many thanks.

[mvidas]

Great!! Glad to help
Let me know if you manage to break it :)

[Zack Barresse]

Matt, you are the man!! That's some beautiful code! :yes

[mvidas]

Thanks :P I think if I ever had to come up with some sort of vba test, this would be one of the final questions!

[brorick]

Hello Matt,

I took your statement, "Let me know if you manage to break it." to heart. Of course I wasn't trying to break it, I just discovered an xml scenerio I didn't anticipate. I have attached the Excel spreadsheet and an XML file. I came across a situation where an xml tag could have an attribute and a value. In this example we are referring to a slideshow xml file.

<Slides>
<slideNode jpegURL="images/image1.jpg">A sea horse</slideNode>
<slideNode jpegURL="images/image2.jpg">Sea anemone</slideNode>
<slideNode jpegURL="images/image3.jpg">Sardines!</slideNode>
<slideNode jpegURL="images/image4.jpg">Another sea horse</slideNode>
<slideNode jpegURL="images/image5.jpg">Some kind of jellyfish</slideNode>
</Slides>

I know this is different than the original example and this post has been closed. So please let me know if you want me to include this as a new post. Thanks. :bow:

[mvidas]

No need for a new post for this.. I'll get back to you in a bit :)

[mvidas]

Well, I want to start off by saying I'm not particularly fond of writing code that has pre-run rules (e.g. same tags need to be grouped together, attributes must be after tag and preceeded by "/@", etc), but I'm introducing one more.

If a tag has attributes and a value like this, the value needs to go last. It is too much work otherwise. An example of how it can't look:

A1: slideNode/@jpegURL
B1: slideNode
C1: slideNode/@Comment

It would have to be restructured to look like:
A1: slideNode/@jpegURL
B1: slideNode/@Comment
C1: slideNode

That being said, here is the updated code, in full:Sub ExportForBrorick()
'http://vbaexpress.com/forum/showthread.php?t=6620
Dim XMLArray() As String, vFF As Long, vFile As String, i As Long

vFile = "C:\" & ThisWorkbook.ActiveSheet.Name & ".xml" 'file to export to
XMLArray = BrorickParseXML(ThisWorkbook.ActiveSheet) 'send sheet to export

vFF = FreeFile
Open vFile For Output As #vFF
For i = 0 To UBound(XMLArray)
Print #vFF, XMLArray(i)
Next
Close #vFF
MsgBox "Done! " & vFile & " created!"
End Sub
Function BrorickParseXML(ByVal WS As Worksheet) As String()
Dim HeadRG As Range, DataRG As Range, CLL As Range, LRow As Range
Dim Tags(), TagCnt As Long, XMLData() As String, TempStr As String
Dim i As Long, j As Long, k As Long, Cnt As Long, TagFlag As Boolean
Dim tArr() As String
Set HeadRG = WS.Range("A1", WS.Cells(1, Columns.Count).End(xlToLeft))
Tags = GetTags(HeadRG)
TagCnt = UBound(Tags)
Set LRow = WS.Cells.Find("*", LookIn:=-4163, SearchOrder:=1, SearchDirection:=2)
Set DataRG = WS.Range("A2", WS.Cells(LRow.Row, 1))
Cnt = 0
ReDim tArr(TagCnt, 0)
For Each CLL In DataRG.Cells
ReDim Preserve tArr(TagCnt, Cnt)
k = 0
For i = 0 To TagCnt
TempStr = "<" & Tags(i)(0)
If UBound(Tags(i)) > 0 Then
For j = 1 To UBound(Tags(i))
If Tags(i)(j) <> "#!#VALUE#!#" Then
TempStr = TempStr & " " & Tags(i)(j) & "=""" & CLL.Offset(0, _
k + j - 1).Text & """"
Else
TempStr = TempStr & ">" & CLL.Offset(0, k + j - 1).Text & _
"</" & Tags(i)(0)
End If
Next 'j
k = k + UBound(Tags(i)) - 1
Else
TempStr = TempStr & ">" & CLL.Offset(0, k).Text & "</" & Tags(i)(0)
End If
TempStr = TempStr & ">"
k = k + 1
tArr(i, Cnt) = TempStr
Next 'i
Cnt = Cnt + 1
Next 'CLL
ReDim XMLData(1)
XMLData(0) = "<?xml version=""1.0""?>"
XMLData(1) = "<" & WS.Name & ">"
Cnt = 2
For i = 0 To UBound(tArr, 2)
For j = 0 To TagCnt
TagFlag = False
If i > 0 Then
For k = 0 To j
If tArr(k, i) <> tArr(k, i - 1) Then
TagFlag = True
Exit For
End If
Next
Else
TagFlag = True
End If
If TagFlag Then
ReDim Preserve XMLData(Cnt)
XMLData(Cnt) = tArr(j, i)
Cnt = Cnt + 1
End If
Next
For j = TagCnt To 0 Step -1
If i < UBound(tArr, 2) And UBound(Tags(j)) > 0 And Tags(j)(UBound _
(Tags(j))) <> "#!#VALUE#!#" Then
TagFlag = False
For k = j To 0 Step -1
If tArr(k, i) <> tArr(k, i + 1) Then
TagFlag = True
Exit For
End If
Next k
If TagFlag Then
ReDim Preserve XMLData(Cnt)
XMLData(Cnt) = "</" & Tags(j)(0) & ">"
Cnt = Cnt + 1
End If
End If
Next
Next
For j = TagCnt To 0 Step -1
If UBound(Tags(j)) > 0 And Tags(j)(UBound(Tags(j))) <> "#!#VALUE#!#" Then
ReDim Preserve XMLData(Cnt)
XMLData(Cnt) = "</" & Tags(j)(0) & ">"
Cnt = Cnt + 1
End If
Next
ReDim Preserve XMLData(Cnt)
XMLData(Cnt) = "</" & WS.Name & ">"
BrorickParseXML = XMLData
End Function
Function GetTags(ByVal TagRange As Range) As Variant()
Dim TagArr(), Cnt As Long, tArr() As String, tCnt As Long, TempArr()
Dim CLL As Range, iPos As Long
ReDim TempArr(TagRange.Cells.Count - 1)
tCnt = 0
For Each CLL In TagRange.Cells
iPos = InStr(1, CLL.Text, "/@")
If iPos > 0 Then
ReDim tArr(1)
tArr(0) = Left$(CLL.Text, iPos - 1)
tArr(1) = Mid$(CLL.Text, iPos + 2)
Else
ReDim tArr(0)
tArr(0) = CLL.Text
End If
TempArr(tCnt) = tArr
tCnt = tCnt + 1
Next
ReDim TagArr(0)
For tCnt = 0 To TagRange.Cells.Count - 1
If tCnt > 0 Then
If TempArr(tCnt)(0) = TempArr(tCnt - 1)(0) Then 'same tag, new attribute
tArr = TagArr(Cnt - 1)
ReDim Preserve tArr(UBound(tArr) + 1)
If UBound(TempArr(tCnt)) > 0 Then
tArr(UBound(tArr)) = TempArr(tCnt)(1)
Else
tArr(UBound(tArr)) = "#!#VALUE#!#"
End If
TagArr(Cnt - 1) = tArr
Else 'new tag
ReDim Preserve TagArr(Cnt)
TagArr(Cnt) = TempArr(tCnt)
Cnt = Cnt + 1
End If
Else 'new tag
ReDim Preserve TagArr(Cnt)
TagArr(Cnt) = TempArr(tCnt)
Cnt = Cnt + 1
End If
Next
GetTags = TagArr
End Function
Please feel free to break it again (as long as you follow the rules :D), I'll keep trying to fix it

[brorick]

Thank you Matt. Your logic makes perfect sense. I will follow the rules and give it a try.