Add dynamic form into excel on button click using VBA - vba

Question

I am trying to create a vba program in excel that exports the user entered data to XML format, so far I have the following:
Below image shows 4 columns
Student Id
Student Name
Student Age
Student Mark
The Export button opens a popup that let the user choose the location of the output xml file with a Convert button
Once the user clicked on the Convert button, the below xml data is generated into the default.xml file
<?xml version="1.0"?>
<data>
<student><id>1</id>
<name>Jad</name>
<age>25</age>
<mark>17</mark>
</student>
</data>
The output seems fine to me so far, but I am looking to add more functionalities, I am trying to add a "Mark" column dynamically on user button click as shown below
Once the user clicks on Add Mark, a new column will appear in order to let the user enter a new grade, or it is better if we can place the new column in a separate form, for example we may add an additional field named Material Name, so on each button click 2 fields will appear Material Name and Material Mark), the expected excel sheet may be something like the below
the expected output of the xml file may be something like the below
<?xml version="1.0"?>
<data>
<student><id>1</id>
<name>Jad</name>
<age>25</age>
<materials>
<material>
<name>Maths</name>
<mark>17</marks>
</material>
<material>
<name>Physics</name>
<mark>18</marks>
</material>
</materials>
</student>
</data>
The function I am used to generate XML file is shown below
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
For more info you can refer to this link https://www.codeproject.com/Articles/6950/Export-Excel-to-XML-in-VBA
Please let me know if you have any suggestions.

Answer 1

It appears the XML Generator you are using already has a function to dynamically search for values until it reaches the last column.
Assuming we only have to modify the first row, it would be as simple as adding a new header to the last empty column
Here are two macros as an example:
Sub ButtonClick()
Call Add_XML_Header("/student/mark")
End Sub
Sub Add_XML_Header(Header As String)
Dim LastColumn As Integer
LastColumn = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
ActiveSheet.Cells(1, LastColumn + 1).Value = Header
End Sub
Assign the first one titled ButtonClick to the button being used in your form.
This will result in an output like this:
Example1
If you wish to go with second option of 2 headers, simply modify the ButtonClick sub like so:
Sub ButtonClick()
Call Add_XML_Header("/student/material/name")
Call Add_XML_Header("/student/material/mark")
End Sub
However, this will slightly differ from your posted example. It will add both columns to the first row horizontally like the other headers rather than vertically as you had shown.
Here's what it would look like:
Example2