vba - 使用VBA在按钮单击时将动态表单添加到excel中
问题描述
我正在尝试在 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>
到目前为止，输出对我来说似乎很好，但我希望添加更多功能，我试图在用户按钮单击时动态添加“标记”列，如下所示
一旦用户点击Add Mark，就会出现一个新列，让用户输入一个新的成绩，或者我们可以将新列放在单独的表单中，例如我们可以添加一个名为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
如果您有任何建议，请告诉我。
解决方案
您正在使用的 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
推荐阅读
- pandas - 从数据框中返回单个值作为数字
- java - 有没有办法使用spring boot rest控制器返回HTML页面作为响应？
- c++ - 如何对特征张量执行某些操作？
- outlook - Microsoft Graph API - 列表消息 API 的 @odata.count 值不准确和一致
- python - 如何创建一个 for 循环以将特定图像从一个文件夹提取到另一个文件夹？
- javascript - 无法从 Android WebView 加载 PHP 提供的 JS 文件
- android - Android Wear 布局开始太低
- excel - 如何从 Excel 中的列表中查找值并将这些文件复制到另一个目录？
- android - 对话框片段包始终为空
- c# - 如何在不读取文本文件的情况下在行尾附加文本？