使用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>

到目前為止，輸出對我來說似乎還不錯，但是我希望添加更多功能，我試圖在用戶按鈕單擊時動態添加“標記”列，如下所示

用戶單擊“ 添加標記”后 ，將出現一個新列，以便用戶輸入新成績，或者最好將新列放置在單獨的表格中，例如，我們可以添加一個名為“ 材料”的附加字段名稱 ，因此在每個按鈕上單擊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 Generator似乎已經具有可以動態搜索值的功能，直到到達最后一列為止。

假設我們只需要修改第一行，就像在最后一個空列中添加新的標題一樣簡單

這里有兩個宏作為示例：

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