从Excel获取记录标签到XML文件,使用Visual Basic Application脚本

huangapple go评论45阅读模式
英文:

Getting Record Tags from Excel to an XML file using Visual Basic Application script

问题

我是新手对VBA一无所知,我有一个可以将Excel文件转换为XML文件的脚本。我需要更改它,使其不再使用预定义的记录标签名称,而是使用Excel数据表中提供的数据。

如果我们以这个Excel表格为例,生成的XML文件将如下所示:

<DeclarationFile>
    <ID>
        <k2>5555.555</k2>
        <k7>2222.222</k7>
        <k15>33.333</k15>
    </ID>
    <ID>
        <k2>4444.444</k2>
        <k7>1111.111</k7>
        <k15>66.666</k15>
    </ID>
    <ID>
        <k2>333.33</k2>
        <k7>5.55</k7>
        <k15>7.77</k15>
    </ID>
</DeclarationFile>

但我需要更改代码,使其使用R14、R17等而不是ID。

整个代码如下:

Sub CreateXMLFile()
' ...(此处省略了一些代码)...

mn_XML_Record_Name = GapFiller(InputBox("2. 输入记录标签名称:", "CreateXMLFile", "ID"))
' ...(此处省略了一些代码)...

For MN_Row = MN_DataRange(mn_second_range, 1) To MN_DataRange(mn_second_range, 2)
    Print #1, "<" & mn_XML_Record_Name & ">"
    ' ...(此处省略了一些代码)...
    Print #1, "</" & mn_XML_Record_Name & ">"
Next MN_Row

' ...(此处省略了一些代码)...
End Sub

如果你需要将代码更改为使用R14、R17等而不是ID,你可以将mn_XML_Record_Name的值更改为相应的标签名称。这样,XML文件将使用R14、R17等作为记录标签名称。不过,请确保你的Excel数据表中包含相应的数据。希望这可以帮助你入门VBA。

英文:

I'm brand new to VBA and I have got a script that turns an Excel into a XML file.
What I need is to change it so that rather using a predefined Record Tag name, it uses data given in the Excel data table.

从Excel获取记录标签到XML文件,使用Visual Basic Application脚本

If we take this Excel table as an example, the XML file would end up being:

DeclarationFile&gt;
	&lt;ID&gt;
		&lt;k2&gt;5555.555&lt;/k2&gt;
		&lt;k7&gt;2222.222&lt;/k7&gt;
		&lt;k15&gt;33.333&lt;/k15&gt;
	&lt;/ID&gt;
	&lt;ID&gt;
		&lt;k2&gt;4444.444&lt;/k2&gt;
		&lt;k7&gt;1111.111&lt;/k7&gt;
		&lt;k15&gt;66.666&lt;/k15&gt;
	&lt;/ID&gt;
	&lt;ID&gt;
		&lt;k2&gt;333.33&lt;/k2&gt;
		&lt;k7&gt;5.55&lt;/k7&gt;
		&lt;k15&gt;7.77&lt;/k15&gt;
	&lt;/ID&gt;
&lt;/DeclarationFile&gt;

But I need to change the code so that it uses the R14, R17 etc instead of ID

The whole code:

Sub CreateXMLFile()
Dim MN_Row As Integer, MN_Column As Integer, MN_TEMP As String, mn_YesOrNo As Variant, mndefine_folder As String
Dim mn_XML_FileName As String, mn_XML_Record_Name As String, mn_LF As String, mn_rtc1 As Integer
Dim mn_first_range As String, mn_second_range As String, mn_tt As String, mn_FieldName(99) As String
mn_LF = Chr(10) &amp; Chr(13)
mndefine_folder = &quot;C:\&quot;
mn_YesOrNo = MsgBox(&quot;Vajadzigs:&quot; &amp; mn_LF _
 &amp; &quot;1. XML File Name&quot; &amp; mn_LF _
 &amp; &quot;2. Record Tag Name&quot; &amp; mn_LF _
 &amp; &quot;3. A Range of Cells Containing Column Headers&quot; &amp; mn_LF _
 &amp; &quot;4. A Range of Cells Containing the Data Table.&quot; &amp; mn_LF _
 &amp; &quot;If You Are Ready To Proceed, Click &#39;Yes&#39;.&quot;, vbQuestion + vbYesNo, &quot;CreateXMLFile&quot;)
If mn_YesOrNo = vbNo Then
 Debug.Print &quot;User Canceled With &#39;No&#39;&quot;
 Exit Sub
End If
mn_XML_FileName = GapFiller(InputBox(&quot;1. Enter the XML File Name:&quot;, &quot;CreateXMLFile&quot;, &quot;xml_file&quot;))
If Right(mn_XML_FileName, 4) &lt;&gt; &quot;.xml&quot; Then
 mn_XML_FileName = mn_XML_FileName &amp; &quot;.xml&quot;
End If
mn_XML_Record_Name = GapFiller(InputBox(&quot;2. Enter The Record Tag Name:&quot;, &quot;CreateXMLFile&quot;, &quot;ID&quot;))
mn_first_range = InputBox(&quot;3. Enter The Range of Cells Containing Column Headers:&quot;, &quot;CreateXMLFile&quot;, &quot;A1:B1&quot;)
If MN_DataRange(mn_first_range, 1) &lt;&gt; MN_DataRange(mn_first_range, 2) Then
  MsgBox &quot;Error: Headers Must Be In The Same Row&quot; &amp; mn_LF &amp; &quot;Atcelts&quot;, vbOKOnly + vbCritical, &quot;CreateXMLFile&quot;
  Exit Sub
End If
MN_Row = MN_DataRange(mn_first_range, 1)
For MN_Column = MN_DataRange(mn_first_range, 3) To MN_DataRange(mn_first_range, 4)
 If Len(Cells(MN_Row, MN_Column).Value) = 0 Then
  MsgBox &quot;Error: Header Contains Empty Cell&quot; &amp; mn_LF &amp; &quot;Canceled&quot;, vbOKOnly + vbCritical, &quot;CreateXMLFile&quot;
  Exit Sub
 End If
 mn_FieldName(MN_Column - MN_DataRange(mn_first_range, 3)) = GapFiller(Cells(MN_Row, MN_Column).Value)
Next MN_Column
mn_second_range = InputBox(&quot;4. Enter The Range of Cells Containing the Data Table:&quot;, &quot;CreateXMLFile&quot;, &quot;A2:B2&quot;)
If MN_DataRange(mn_first_range, 4) - MN_DataRange(mn_first_range, 3) &lt;&gt; MN_DataRange(mn_second_range, 4) - MN_DataRange(mn_second_range, 3) Then
  MsgBox &quot;Error: There Are More Or Less Headers Than Columns of Data&quot; &amp; mn_LF &amp; &quot;Canceled&quot;, vbOKOnly + vbCritical, &quot;CreateXMLFile&quot;
  Exit Sub
End If
mn_rtc1 = MN_DataRange(mn_second_range, 3)
If InStr(1, mn_XML_FileName, &quot;:\&quot;) = 0 Then
 mn_XML_FileName = mndefine_folder &amp; mn_XML_FileName
End If
Open mn_XML_FileName For Output As #1
Print #1, &quot;&lt;?xml version=&quot; &amp; Chr(34) &amp; &quot;1.0&quot; &amp; Chr(34) &amp; &quot; encoding=&quot; &amp; Chr(34) &amp; &quot;ISO-8859-1&quot; &amp; Chr(34) &amp; &quot;?&gt;&quot;
Print #1, &quot;&lt;DeclarationFile&gt;&quot;
For MN_Row = MN_DataRange(mn_second_range, 1) To MN_DataRange(mn_second_range, 2)
Print #1, &quot;&lt;&quot; &amp; mn_XML_Record_Name &amp; &quot;&gt;&quot;
  For MN_Column = mn_rtc1 To MN_DataRange(mn_second_range, 4)
    Print #1, &quot;&lt;&quot; &amp; mn_FieldName(MN_Column - mn_rtc1) &amp; &quot;&gt;&quot; &amp; AmpersandEliminate(CheckForm(MN_Row, MN_Column)) &amp; &quot;&lt;/&quot; &amp; mn_FieldName(MN_Column - mn_rtc1) &amp; &quot;&gt;&quot;
    Next MN_Column
 Print #1, &quot;&lt;/&quot; &amp; mn_XML_Record_Name &amp; &quot;&gt;&quot;
Next MN_Row
Print #1, &quot;&lt;/DeclarationFile&gt;&quot;
Close #1
MsgBox mn_XML_FileName &amp; &quot; izveidots.&quot; &amp; mn_LF &amp; &quot;Completed&quot;, vbOKOnly + vbInformation, &quot;CreateXMLFile&quot;
Debug.Print mn_XML_FileName &amp; &quot; saved&quot;
End Sub
Function MN_DataRange(Rng_As_Text As String, MN_Item As Integer) As Integer
Dim MN_user_range As Range
Set MN_user_range = Range(Rng_As_Text)
Select Case MN_Item
 Case 1
 MN_DataRange = MN_user_range.Row
 Case 2
 MN_DataRange = MN_user_range.Row + MN_user_range.Rows.Count - 1
 Case 3
 MN_DataRange = MN_user_range.Column
 Case 4
 MN_DataRange = MN_user_range.Columns(MN_user_range.Columns.Count).Column
End Select
Exit Function
End Function
Function GapFiller(mn_my_Str As String) As String
Dim mn_Position As Integer
mn_Position = InStr(1, mn_my_Str, &quot; &quot;)
Do While mn_Position &gt; 0
 Mid(mn_my_Str, mn_Position, 1) = &quot;_&quot;
 mn_Position = InStr(1, mn_my_Str, &quot; &quot;)
Loop
GapFiller = LCase(mn_my_Str)
End Function
Function CheckForm(mn_Row_Number As Integer, mn_Column_Number As Integer) As String
CheckForm = Cells(mn_Row_Number, mn_Column_Number).Value
If IsNumeric(Cells(mn_Row_Number, mn_Column_Number).Value) Then
 CheckForm = Format(Cells(mn_Row_Number, mn_Column_Number).Value, &quot;#,##0 ;(#,##0)&quot;)
End If
If IsDate(Cells(mn_Row_Number, mn_Column_Number).Value) Then
 CheckForm = Format(Cells(mn_Row_Number, mn_Column_Number).Value, &quot;dd mmm yy&quot;)
End If
End Function
Function AmpersandEliminate(mn_my_Str As String) As String
Dim mn_Position As Integer
mn_Position = InStr(1, mn_my_Str, &quot;&amp;&quot;)
Do While mn_Position &gt; 0
 Mid(mn_my_Str, mn_Position, 1) = &quot;+&quot;
 mn_Position = InStr(1, mn_my_Str, &quot;&amp;&quot;)
Loop
AmpersandEliminate = mn_my_Str
End Function

Since I am completely clueless with VBA, I was getting array errors and "argument not optional"

Any tips on where to start are appreciated!

答案1

得分: 0

请试试这个:

Sub CreateXMLFile()
    Const THE_FOLDER As String = "C:\"
    Dim ws As Worksheet, rngData As Range, fName As String, rw As Long, col As Long
    Dim xml As String, tagId As String, tagVal As String, v
    
    If MsgBox("要尝试这个:" & vbLf & "1. XML文件名称" & vbLf & _
        "2. 包含数据表的单元格范围(包括标题)。" & vbLf & _
        "如果您准备好了,请单击 '是'。", vbQuestion + vbYesNo, "CreateXMLFile") <> vbYes Then
            Debug.Print "用户取消了,选择 '否'"
            Exit Sub
    End If
    
    ' 最好在这里使用 `Application.GetSaveAsFileName`...
    fName = Application.GetSaveAsFilename(filefilter:="XML (*.xml),*.xml", _
                                 Title:="1. 选择保存XML文件的名称")
    
    On Error Resume Next ' 如果未选择范围,忽略错误
    Set rngData = Application.InputBox("2. 选择包含数据的范围(包括标题):", _
                                       "CreateXMLFile", Type:=8)
    On Error Resume Next ' 停止忽略错误
    
    If rngData Is Nothing Then
        Debug.Print "用户没有选择范围"
        Exit Sub
    End If
    
    Open fName For Output As #1
    Print #1, "<?xml version=""1.0""  encoding=""ISO-8859-1""?>"
    Print #1, "<DeclarationFile>"
    
    For rw = 2 To rngData.Rows.Count
        tagId = rngData.Cells(rw, 1).Value
        Print #1, "<" & tagId & ">"
        For col = 2 To rngData.Columns.Count
            tagVal = rngData.Cells(1, col).Value
            v = rngData.Cells(rw, col).Value
            Print #1, "<" & tagVal & ">" & Replace(CheckForm(v), "&", "+") & "</" & tagVal & ">"
        Next col
        Print #1, "</" & tagId & ">"
    Next rw
    Print #1, "</DeclarationFile>"
    
    Open fName For Output As #1
    Close #1
    
    MsgBox fName & " 创建。" & vbLf & "已完成", vbOKOnly + vbInformation, "CreateXMLFile"
    Debug.Print fName & " 已保存"
End Sub

Function CheckForm(v) As String
    If IsNumeric(v) Then v = Format(v, "#,##0 ;(#,##0)")
    If IsDate(v) Then v = Format(v, "dd mmm yy")
    CheckForm = CStr(v)
End Function
英文:

Try this:

Sub CreateXMLFile()
    Const THE_FOLDER As String = &quot;C:\&quot;
    Dim ws As Worksheet, rngData As Range, fName As String, rw As Long, col As Long
    Dim xml As String, tagId As String, tagVal As String, v
    
    If MsgBox(&quot;Vajadzigs:&quot; &amp; vbLf &amp; &quot;1. XML File Name&quot; &amp; vbLf &amp; _
        &quot;2. A Range of Cells Containing the Data Table (with headers).&quot; &amp; vbLf &amp; _
        &quot;If You Are Ready To Proceed, Click &#39;Yes&#39;.&quot;, vbQuestion + vbYesNo, &quot;CreateXMLFile&quot;) &lt;&gt; vbYes Then
            Debug.Print &quot;User Canceled With &#39;No&#39;&quot;
            Exit Sub
    End If
    
    &#39;would be better to use `Application.GetSaveAsFileName` here...
    fName = Application.GetSaveAsFilename(filefilter:=&quot;XML (*.xml),*.xml&quot;, _
                                 Title:=&quot;1. Select SaveAs name for XML file&quot;)
    
    
    On Error Resume Next &#39;ignore error if not range selected
    Set rngData = Application.InputBox(&quot;2. Select the range with data (include headers):&quot;, _
                                       &quot;CreateXMLFile&quot;, Type:=8)
    On Error Resume Next &#39;stop ignoring error
    
    If rngData Is Nothing Then
        Debug.Print &quot;User did not select a range&quot;
        Exit Sub
    End If
    
    Open fName For Output As #1
    Print #1, &quot;&lt;?xml version=&quot;&quot;1.0&quot;&quot;  encoding=&quot;&quot;ISO-8859-1&quot;&quot;?&gt;&quot;
    Print #1, &quot;&lt;DeclarationFile&gt;&quot;
    
    For rw = 2 To rngData.Rows.Count
        tagId = rngData.Cells(rw, 1).Value
        Print #1, &quot;&lt;&quot; &amp; tagId &amp; &quot;&gt;&quot;
        For col = 2 To rngData.Columns.Count
            tagVal = rngData.Cells(1, col).Value
            v = rngData.Cells(rw, col).Value
            Print #1, &quot;&lt;&quot; &amp; tagVal &amp; &quot;&gt;&quot; &amp; Replace(CheckForm(v), &quot;&amp;&quot;, &quot;+&quot;) &amp; &quot;&lt;/&quot; &amp; tagVal &amp; &quot;&gt;&quot;
        Next col
        Print #1, &quot;&lt;/&quot; &amp; tagId &amp; &quot;&gt;&quot;
    Next rw
    Print #1, &quot;&lt;/DeclarationFile&gt;&quot;
    
    Open fName For Output As #1
    Close #1
    
    MsgBox fName &amp; &quot; izveidots.&quot; &amp; vbLf &amp; &quot;Completed&quot;, vbOKOnly + vbInformation, &quot;CreateXMLFile&quot;
    Debug.Print fName &amp; &quot; saved&quot;
End Sub

Function CheckForm(v) As String
    If IsNumeric(v) Then v = Format(v, &quot;#,##0 ;(#,##0)&quot;)
    If IsDate(v) Then v = Format(v, &quot;dd mmm yy&quot;)
    CheckForm = CStr(v)
End Function

huangapple
  • 本文由 发表于 2023年2月16日 02:54:57
  • 转载请务必保留本文链接:https://go.coder-hub.com/75464298.html
匿名

发表评论

匿名网友

:?: :razz: :sad: :evil: :!: :smile: :oops: :grin: :eek: :shock: :???: :cool: :lol: :mad: :twisted: :roll: :wink: :idea: :arrow: :neutral: :cry: :mrgreen:

确定