Add dynamic form into excel on button click using 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