Ecexl中的VBA导出表内的数据到XML

来源：互联网发布：mysql pdf 百度云编辑：程序博客网时间：2024/05/07 00:42

作用：

为了方便策划填表，导表，我需要做一个功能就是在Ecexl中添加一个按钮实现自动导表功能。

实现方法：

主要使用 DOMDocument 模型，（需要添加 XML控件：工具-> 引用->选择Microsoft XML，V3.0）实现XML，遍历表格让每一行形成一条XML数据。把第一行当做属性名称，形成特定格式。

代码如下：

Option Explicit '语句在模块级别中使用，强制显式声明模块中的所有变量。Sub Main()    Dim xmlName As String 'XML名称    Dim xmlDoc As DOMDocument'数据总表    Dim xmlPI As IXMLDOMProcessingInstruction'数据总表属性获得这些参数值    Dim xmlRoot As IXMLDOMElement'总表数据    Dim xmlVoucher As IXMLDOMElement'每行数据    Dim I As Long    Dim M As Long    Dim DataRange As Variant    Dim TextEnd As Long    Dim NeedToGetBigger As Long    TextEnd = 5    NeedToGetBigger = 1    xmlName = VBA.UCase(Left(ActiveWorkbook.name, NeedToGetBigger)) + Mid(ActiveWorkbook.name, 1 + NeedToGetBigger, (Len(ActiveWorkbook.name) - NeedToGetBigger - TextEnd))    Set xmlDoc = New DOMDocument    Set xmlPI = xmlDoc.createProcessingInstruction("xml", "version=""1.0"" encoding=""utf-8""")    xmlDoc.appendChild xmlPI    Set xmlRoot = xmlDoc.createElement("ArrayOf" + xmlName)    xmlDoc.appendChild xmlRoot    Dim Rows As Long    Dim Columns As Long    Rows = ActiveSheet.UsedRange.Rows.Count    Columns = ActiveSheet.UsedRange.Columns.Count    DataRange = Sheet1.Range("A1:BU900").value    For I = 2 To Rows        Set xmlVoucher = AddChild(xmlDoc, xmlRoot, xmlName)        For M = 1 To Columns            AddEntry xmlDoc, xmlVoucher, DataRange(1, M), DataRange(I, M)        Next M    Next I    Dim Path As String    Path = Application.ActiveWorkbook.Path + "\..\" + Left(ActiveWorkbook.name, Len(ActiveWorkbook.name) - TextEnd) + ".xml"    xmlDoc.Save Path    MsgBox "Export file success ..."End SubFunction AddChild(ByVal xmlDoc As DOMDocument, _                  ByVal xmlParent As IXMLDOMElement, _                  ByVal tagName As String _                 ) As IXMLDOMElement    Dim xmlChild As IXMLDOMElement    Set xmlChild = xmlDoc.createElement(tagName)    xmlParent.appendChild xmlChild    Set AddChild = xmlChildEnd FunctionFunction AddTextChild(ByVal xmlDoc As DOMDocument, _                      ByVal xmlParent As IXMLDOMElement, _                      ByVal tagName As String, _                      ByVal Text As String _                     ) As IXMLDOMElement    Dim xmlChild As IXMLDOMElement    Dim xmlText  As IXMLDOMText    Set xmlChild = xmlDoc.createElement(tagName)    xmlParent.appendChild xmlChild    xmlChild.Text = Text    Set AddTextChild = xmlChildEnd FunctionSub AddEntry(ByVal xmlDoc As DOMDocument, _             ByVal xmlParent As IXMLDOMElement, _             ByVal name As String, _             ByVal value As String)    AddTextChild xmlDoc, xmlParent, name, valueEnd Sub

下面记录一些经常用到的 VBA 函数

VBA如何获取当前EXCEL文件的路径

返回应用程序完整路径
Application.Path

返回当前工作薄的路径
ThisWorkbook.Path

返回当前默认文件路径：
Application.DefaultFilePath

Application.ActiveWorkbook.Path 只返回路径
Application.ActiveWorkbook.FullName 返回路径及工作簿文件名
Application.ActiveWorkbook.Name 返回工作簿文件名

该微博转自：http://blog.csdn.net/wuyang8/article/details/54571673

0 0