英文:
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.
If we take this Excel table as an example, the XML file would end up being:
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>
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) & Chr(13)
mndefine_folder = "C:\"
mn_YesOrNo = MsgBox("Vajadzigs:" & mn_LF _
& "1. XML File Name" & mn_LF _
& "2. Record Tag Name" & mn_LF _
& "3. A Range of Cells Containing Column Headers" & mn_LF _
& "4. A Range of Cells Containing the Data Table." & mn_LF _
& "If You Are Ready To Proceed, Click 'Yes'.", vbQuestion + vbYesNo, "CreateXMLFile")
If mn_YesOrNo = vbNo Then
Debug.Print "User Canceled With 'No'"
Exit Sub
End If
mn_XML_FileName = GapFiller(InputBox("1. Enter the XML File Name:", "CreateXMLFile", "xml_file"))
If Right(mn_XML_FileName, 4) <> ".xml" Then
mn_XML_FileName = mn_XML_FileName & ".xml"
End If
mn_XML_Record_Name = GapFiller(InputBox("2. Enter The Record Tag Name:", "CreateXMLFile", "ID"))
mn_first_range = InputBox("3. Enter The Range of Cells Containing Column Headers:", "CreateXMLFile", "A1:B1")
If MN_DataRange(mn_first_range, 1) <> MN_DataRange(mn_first_range, 2) Then
MsgBox "Error: Headers Must Be In The Same Row" & mn_LF & "Atcelts", vbOKOnly + vbCritical, "CreateXMLFile"
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 "Error: Header Contains Empty Cell" & mn_LF & "Canceled", vbOKOnly + vbCritical, "CreateXMLFile"
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("4. Enter The Range of Cells Containing the Data Table:", "CreateXMLFile", "A2:B2")
If MN_DataRange(mn_first_range, 4) - MN_DataRange(mn_first_range, 3) <> MN_DataRange(mn_second_range, 4) - MN_DataRange(mn_second_range, 3) Then
MsgBox "Error: There Are More Or Less Headers Than Columns of Data" & mn_LF & "Canceled", vbOKOnly + vbCritical, "CreateXMLFile"
Exit Sub
End If
mn_rtc1 = MN_DataRange(mn_second_range, 3)
If InStr(1, mn_XML_FileName, ":\") = 0 Then
mn_XML_FileName = mndefine_folder & mn_XML_FileName
End If
Open mn_XML_FileName For Output As #1
Print #1, "<?xml version=" & Chr(34) & "1.0" & Chr(34) & " encoding=" & Chr(34) & "ISO-8859-1" & Chr(34) & "?>"
Print #1, "<DeclarationFile>"
For MN_Row = MN_DataRange(mn_second_range, 1) To MN_DataRange(mn_second_range, 2)
Print #1, "<" & mn_XML_Record_Name & ">"
For MN_Column = mn_rtc1 To MN_DataRange(mn_second_range, 4)
Print #1, "<" & mn_FieldName(MN_Column - mn_rtc1) & ">" & AmpersandEliminate(CheckForm(MN_Row, MN_Column)) & "</" & mn_FieldName(MN_Column - mn_rtc1) & ">"
Next MN_Column
Print #1, "</" & mn_XML_Record_Name & ">"
Next MN_Row
Print #1, "</DeclarationFile>"
Close #1
MsgBox mn_XML_FileName & " izveidots." & mn_LF & "Completed", vbOKOnly + vbInformation, "CreateXMLFile"
Debug.Print mn_XML_FileName & " saved"
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, " ")
Do While mn_Position > 0
Mid(mn_my_Str, mn_Position, 1) = "_"
mn_Position = InStr(1, mn_my_Str, " ")
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, "#,##0 ;(#,##0)")
End If
If IsDate(Cells(mn_Row_Number, mn_Column_Number).Value) Then
CheckForm = Format(Cells(mn_Row_Number, mn_Column_Number).Value, "dd mmm yy")
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, "&")
Do While mn_Position > 0
Mid(mn_my_Str, mn_Position, 1) = "+"
mn_Position = InStr(1, mn_my_Str, "&")
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 = "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("Vajadzigs:" & vbLf & "1. XML File Name" & vbLf & _
"2. A Range of Cells Containing the Data Table (with headers)." & vbLf & _
"If You Are Ready To Proceed, Click 'Yes'.", vbQuestion + vbYesNo, "CreateXMLFile") <> vbYes Then
Debug.Print "User Canceled With 'No'"
Exit Sub
End If
'would be better to use `Application.GetSaveAsFileName` here...
fName = Application.GetSaveAsFilename(filefilter:="XML (*.xml),*.xml", _
Title:="1. Select SaveAs name for XML file")
On Error Resume Next 'ignore error if not range selected
Set rngData = Application.InputBox("2. Select the range with data (include headers):", _
"CreateXMLFile", Type:=8)
On Error Resume Next 'stop ignoring error
If rngData Is Nothing Then
Debug.Print "User did not select a range"
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 & " izveidots." & vbLf & "Completed", vbOKOnly + vbInformation, "CreateXMLFile"
Debug.Print fName & " saved"
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
通过集体智慧和协作来改善编程学习和解决问题的方式。致力于成为全球开发者共同参与的知识库,让每个人都能够通过互相帮助和分享经验来进步。
评论