如何生成excel文件到xml

时间：2011-03-08 06:19:09

标签： xml excel vba

我有一个带有表单结构的excel文件。我需要这个表单结构excel sheert将转换为xml。例如，excel表具有以下结构。

Student Name ...........      Age......
Roll No      .........


---------------------------------
| sn | Subject |  Marks  |Total |
|    |         |---------|      |
|    |         |Max |Obt.|      |
---------------------------------
|  1 | maths   | 100| 85 | 85   |
---------------------------------
|  2 | Eng     | 100| 85 | 85   |
---------------------------------
|  3 | lang2   | 100| 85 | 85   |
---------------------------------
|  4 | Science | 100| 85 | 85   |
---------------------------------

------------    Total marks: 340        
|Grade| A  |
------------

表结构中有一些数据和标记。为此，我需要xml格式。 有人可以帮忙吗？

提前致谢。

Eshwer

3 个答案:

答案 0 :(得分：1)

我对Excel几乎没有任何了解，因此它可能具有内置函数。

但如果没有这样的功能，快速而肮脏的方法是在电子表格中构建XML节点，并进行连接。例如：="<"&A1&">"&A2&"</"&A1&">"。

它会使用导出内容污染您的电子表格，但它会很快运行并允许您添加数据或列并将其考虑在内而不会产生任何痛苦（我已经完成了）。

答案 1 :(得分：0)

根据您要执行的操作以及您使用的Excel版本，您可以：

或使用此VBA：

Attribute VB_Name = "XL_to_XML"
Sub MakeXML()
' create an XML file from an Excel table
Dim MyRow As Integer, MyCol As Integer, Temp As String, YesNo As Variant, DefFolder As String
Dim XMLFileName As String, XMLRecSetName As String, MyLF As String, RTC1 As Integer
Dim RangeOne As String, RangeTwo As String, Tt As String, FldName(99) As String

MyLF = Chr(10) & Chr(13)    ' a line feed command
DefFolder = "C:\"   'change this to the location of saved XML files

YesNo = MsgBox("This procedure requires the following data:" & MyLF _
 & "1 A filename for the XML file" & MyLF _
 & "2 A groupname for an XML record" & MyLF _
 & "3 A cellrange containing fieldnames (col titles)" & MyLF _
 & "4 A cellrange containing the data table" & MyLF _
 & "Are you ready to proceed?", vbQuestion + vbYesNo, "MakeXML CiM")

If YesNo = vbNo Then
 Debug.Print "User aborted with 'No'"
 Exit Sub
End If

XMLFileName = FillSpaces(InputBox("1. Enter the name of the XML file:", "MakeXML CiM", "xl_xml_data"))
If Right(XMLFileName, 4) <> ".xml" Then
 XMLFileName = XMLFileName & ".xml"
End If

XMLRecSetName = FillSpaces(InputBox("2. Enter an identifying name of a record:", "MakeXML CiM", "record"))

RangeOne = InputBox("3. Enter the range of cells containing the field names (or column titles):", "MakeXML CiM", "A3:D3")
If MyRng(RangeOne, 1) <> MyRng(RangeOne, 2) Then
  MsgBox "Error: names must be on a single row" & MyLF & "Procedure STOPPED", vbOKOnly + vbCritical, "MakeXML CiM"
  Exit Sub
End If
MyRow = MyRng(RangeOne, 1)
For MyCol = MyRng(RangeOne, 3) To MyRng(RangeOne, 4)
 If Len(Cells(MyRow, MyCol).Value) = 0 Then
  MsgBox "Error: names range contains blank cell" & MyLF & "Procedure STOPPED", vbOKOnly + vbCritical, "MakeXML CiM"
  Exit Sub
 End If
 FldName(MyCol - MyRng(RangeOne, 3)) = FillSpaces(Cells(MyRow, MyCol).Value)
Next MyCol

RangeTwo = InputBox("4. Enter the range of cells containing the data table:", "MakeXML CiM", "A4:D8")
If MyRng(RangeOne, 4) - MyRng(RangeOne, 3) <> MyRng(RangeTwo, 4) - MyRng(RangeTwo, 3) Then
  MsgBox "Error: number of field names <> data columns" & MyLF & "Procedure STOPPED", vbOKOnly + vbCritical, "MakeXML CiM"
  Exit Sub
End If
RTC1 = MyRng(RangeTwo, 3)

If InStr(1, XMLFileName, ":\") = 0 Then
 XMLFileName = DefFolder & XMLFileName
End If

Open XMLFileName For Output As #1
Print #1, "<?xml version=" & Chr(34) & "1.0" & Chr(34) & " encoding=" & Chr(34) & "ISO-8859-1" & Chr(34) & "?>"
Print #1, "<meadinkent>"

For MyRow = MyRng(RangeTwo, 1) To MyRng(RangeTwo, 2)
Print #1, "<" & XMLRecSetName & ">"
  For MyCol = RTC1 To MyRng(RangeTwo, 4)
  ' the next line uses the FormChk function to format dates and numbers
     Print #1, "<" & FldName(MyCol - RTC1) & ">" & RemoveAmpersands(FormChk(MyRow, MyCol)) & "</" & FldName(MyCol - RTC1) & ">"
  ' the next line does not apply any formatting
  '  Print #1, "<" & FldName(MyCol - RTC1) & ">" & RemoveAmpersands(Cells(MyRow, MyCol).Value) & "</" & FldName(MyCol - RTC1) & ">"
    Next MyCol
 Print #1, "</" & XMLRecSetName & ">"

Next MyRow
Print #1, "</meadinkent>"
Close #1
MsgBox XMLFileName & " created." & MyLF & "Process finished", vbOKOnly + vbInformation, "MakeXML CiM"
Debug.Print XMLFileName & " saved"
End Sub
Function MyRng(MyRangeAsText As String, MyItem As Integer) As Integer
' analyse a range, where MyItem represents 1=TR, 2=BR, 3=LHC, 4=RHC

Dim UserRange As Range
Set UserRange = Range(MyRangeAsText)
Select Case MyItem
 Case 1
 MyRng = UserRange.Row
 Case 2
 MyRng = UserRange.Row + UserRange.Rows.Count - 1
 Case 3
 MyRng = UserRange.Column
 Case 4
 MyRng = UserRange.Columns(UserRange.Columns.Count).Column
End Select
Exit Function

End Function
Function FillSpaces(AnyStr As String) As String
' remove any spaces and replace with underscore character
Dim MyPos As Integer
MyPos = InStr(1, AnyStr, " ")
Do While MyPos > 0
 Mid(AnyStr, MyPos, 1) = "_"
 MyPos = InStr(1, AnyStr, " ")
Loop
FillSpaces = LCase(AnyStr)
End Function

Function FormChk(RowNum As Integer, ColNum As Integer) As String
' formats numeric and date cell values to comma 000's and DD MMM YY
FormChk = Cells(RowNum, ColNum).Value
If IsNumeric(Cells(RowNum, ColNum).Value) Then
 FormChk = Format(Cells(RowNum, ColNum).Value, "#,##0 ;(#,##0)")
End If
If IsDate(Cells(RowNum, ColNum).Value) Then
 FormChk = Format(Cells(RowNum, ColNum).Value, "dd mmm yy")
End If
End Function

Function RemoveAmpersands(AnyStr As String) As String
Dim MyPos As Integer
' replace Ampersands (&) with plus symbols (+)

MyPos = InStr(1, AnyStr, "&")
Do While MyPos > 0
 Mid(AnyStr, MyPos, 1) = "+"
 MyPos = InStr(1, AnyStr, "&")
Loop
RemoveAmpersands = AnyStr
End Function

发现自：http://www.meadinkent.co.uk/xl_xml1.htm

希望它有所帮助，

答案 2 :(得分：0)

正如JMax所说，你有内置函数可以做到这一点。首先，你必须根据excel电子表格编写XML Schema定义。成功创建xsd文件后，您需要执行以下步骤..  1）点击“文件”（我假设你有Excel 2007或更高版本） 2）点击“选项” 3）在弹出窗口中“Excel选项”单击“自定义功能区” 4）检查“开发人员”并单击确定。 5）现在，您将在Excel中获得开发人员选项卡。单击此选项卡。 6）单击“Source”并浏览您的xsd文件。 7）在此之后，您必须通过拖放方法或选择列和Map元素来映射元素。

我希望这有帮助..

相关问题
最新问题