使用VBA在按钮单击时将动态表单添加到excel中

Question

我正在尝试在 excel 中创建一个 vba 程序，将用户输入的数据导出为 XML 格式，到目前为止，我有以下内容：

下图显示 4 列

• 学生证
• 学生姓名
• 学生年龄
• 学生马克

导出按钮打开一个弹出窗口，让用户使用转换按钮选择输出 xml 文件的位置

一旦用户点击转换按钮，下面的xml数据就会生成到default.xml文件中

<?xml version="1.0"?>
<data>
  <student><id>1</id>
    <name>Jad</name>
    <age>25</age>
    <mark>17</mark>
  </student>
</data>

到目前为止，输出对我来说似乎很好，但我希望添加更多功能，我正在尝试在用户按钮单击时动态添加“标记”列，如下所示

一旦用户点击添加标记，就会出现一个新的列，让用户输入一个新的成绩，或者我们可以将新列放在一个单独的表单中，例如我们可以添加一个名为 Material Name 的附加字段，因此在每个按钮单击 2 个字段时会出现 Material Name 和 Material Mark），预期的 excel 表可能如下所示

xml 文件的预期输出可能如下所示

<?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>

我用来生成XML文件的函数如下所示

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

更多信息可以参考这个链接https://www.codeproject.com/Articles/6950/Export-Excel-to-XML-in-VBA

如果您有任何建议，请告诉我。

Answer 1

您正在使用的 XML 生成器似乎已经具有动态搜索值直到到达最后一列的功能。

假设我们只需要修改第一行，这就像在最后一个空列

中添加一个新标题一样简单

这里以两个宏为例：

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

将标题为 ButtonClick 的第一个按钮分配给表单中使用的按钮。

这将产生如下输出： Example1

如果您希望使用 2 个标题的第二个选项，只需像这样修改 ButtonClick 子：

Sub ButtonClick()
    Call Add_XML_Header("/student/material/name")
    Call Add_XML_Header("/student/material/mark")
End Sub

但是，这与您发布的示例略有不同。它将像其他标题一样将两列水平添加到第一行，而不是像您显示的那样垂直添加。

这是它的样子： Example2