2010-05-04 75 views
6

所以,我收到了一堆以Excel电子表格形式发送给我们的内容。我需要把这些内容带入另一个系统。另一个系统从XML文件中获取输入。我可以手工完成所有这些工作(并且相信我,管理层没有问题让我这么做!),但是我希望有一种简单的方法可以编写一个Excel宏,以生成我需要的XML。这对我来说似乎是一个更好的解决方案,因为这是一项需要定期重复的工作(我们将在Excel工作表中获得大量内容),并且有一个批处理工具可以帮助我们完成工作。如何从Excel VBA宏生成XML?

但是,我从来没有尝试过从Excel电子表格生成XML。我有一点VBA的知识,但我是XML的新手。我想我在Google上搜索的问题是,我甚至不知道Google为什么要这么做。任何人都可以给我一个方向让我开始?我的想法听起来像是解决这个问题的正确方法,还是我忽略了一些明显的东西?

感谢StackOverflow!

回答

5

您可能会考虑ADO - 工作表或范围可以用作表格。

Const adOpenStatic = 3 
Const adLockOptimistic = 3 
Const adPersistXML = 1 

Set cn = CreateObject("ADODB.Connection") 
Set rs = CreateObject("ADODB.Recordset") 

''It wuld probably be better to use the proper name, but this is 
''convenient for notes 
strFile = Workbooks(1).FullName 

''Note HDR=Yes, so you can use the names in the first row of the set 
''to refer to columns, note also that you will need a different connection 
''string for >=2007 
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile _ 
     & ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"";" 


cn.Open strCon 
rs.Open "Select * from [Sheet1$]", cn, adOpenStatic, adLockOptimistic 

If Not rs.EOF Then 
    rs.MoveFirst 
    rs.Save "C:\Docs\Table1.xml", adPersistXML 
End If 

rs.Close 
cn.Close 
+0

这个节拍使用200,000行循环+1 :) – 2015-07-06 16:13:02

+0

惊人快! – indofraiser 2016-01-22 12:28:47

3

感谢:curiousmind.jlion.com/exceltotextfile(链接已不存在)

脚本:

Sub MakeXML(iCaptionRow As Integer, iDataStartRow As Integer, sOutputFileName As String) 
    Dim Q As String 
    Q = Chr$(34) 

    Dim sXML As String 

    sXML = "<?xml version=" & Q & "1.0" & Q & " encoding=" & Q & "UTF-8" & Q & "?>" 
    sXML = sXML & "<rows>" 


    ''--determine count of columns 
    Dim iColCount As Integer 
    iColCount = 1 
    While Trim$(Cells(iCaptionRow, iColCount)) > "" 
     iColCount = iColCount + 1 
    Wend 

    Dim iRow As Integer 
    iRow = iDataStartRow 

    While Cells(iRow, 1) > "" 
     sXML = sXML & "<row id=" & Q & iRow & Q & ">" 

     For icol = 1 To iColCount - 1 
      sXML = sXML & "<" & Trim$(Cells(iCaptionRow, icol)) & ">" 
      sXML = sXML & Trim$(Cells(iRow, icol)) 
      sXML = sXML & "</" & Trim$(Cells(iCaptionRow, icol)) & ">" 
     Next 

     sXML = sXML & "</row>" 
     iRow = iRow + 1 
    Wend 
    sXML = sXML & "</rows>" 

    Dim nDestFile As Integer, sText As String 

    ''Close any open text files 
    Close 

    ''Get the number of the next free text file 
    nDestFile = FreeFile 

    ''Write the entire file to sText 
    Open sOutputFileName For Output As #nDestFile 
    Print #nDestFile, sXML 
    Close 
End Sub 

Sub test() 
    MakeXML 1, 2, "C:\Users\jlynds\output2.xml" 
End Sub 
0

这一个多版本 - 这将在通用

Public strSubTag As String 
Public iStartCol As Integer 
Public iEndCol As Integer 
Public strSubTag2 As String 
Public iStartCol2 As Integer 
Public iEndCol2 As Integer 

Sub Create() 
Dim strFilePath As String 
Dim strFileName As String 

'ThisWorkbook.Sheets("Sheet1").Range("C3").Activate 
'strTag = ActiveCell.Offset(0, 1).Value 
strFilePath = ThisWorkbook.Sheets("Sheet1").Range("B4").Value 
strFileName = ThisWorkbook.Sheets("Sheet1").Range("B5").Value 
strSubTag = ThisWorkbook.Sheets("Sheet1").Range("F3").Value 
iStartCol = ThisWorkbook.Sheets("Sheet1").Range("F4").Value 
iEndCol = ThisWorkbook.Sheets("Sheet1").Range("F5").Value 

strSubTag2 = ThisWorkbook.Sheets("Sheet1").Range("G3").Value 
iStartCol2 = ThisWorkbook.Sheets("Sheet1").Range("G4").Value 
iEndCol2 = ThisWorkbook.Sheets("Sheet1").Range("G5").Value 

Dim iCaptionRow As Integer 
iCaptionRow = ThisWorkbook.Sheets("Sheet1").Range("B3").Value 
'strFileName = ThisWorkbook.Sheets("Sheet1").Range("B4").Value 
MakeXML iCaptionRow, iCaptionRow + 1, strFilePath, strFileName 

End Sub 


Sub MakeXML(iCaptionRow As Integer, iDataStartRow As Integer, sOutputFilePath As String, sOutputFileName As String) 
    Dim Q As String 
    Dim sOutputFileNamewithPath As String 
    Q = Chr$(34) 

    Dim sXML As String 


    'sXML = sXML & "<rows>" 

' ''--determine count of columns 
    Dim iColCount As Integer 
    iColCount = 1 

    While Trim$(Cells(iCaptionRow, iColCount)) > "" 
     iColCount = iColCount + 1 
    Wend 


    Dim iRow As Integer 
    Dim iCount As Integer 
    iRow = iDataStartRow 
    iCount = 1 
    While Cells(iRow, 1) > "" 
     'sXML = sXML & "<row id=" & Q & iRow & Q & ">" 
     sXML = "<?xml version=" & Q & "1.0" & Q & " encoding=" & Q & "UTF-8" & Q & "?>" 
     For iCOl = 1 To iColCount - 1 
      If (iStartCol = iCOl) Then 
       sXML = sXML & "<" & strSubTag & ">" 
      End If 
      If (iEndCol = iCOl) Then 
       sXML = sXML & "</" & strSubTag & ">" 
      End If 
     If (iStartCol2 = iCOl) Then 
       sXML = sXML & "<" & strSubTag2 & ">" 
      End If 
      If (iEndCol2 = iCOl) Then 
       sXML = sXML & "</" & strSubTag2 & ">" 
      End If 
      sXML = sXML & "<" & Trim$(Cells(iCaptionRow, iCOl)) & ">" 
      sXML = sXML & Trim$(Cells(iRow, iCOl)) 
      sXML = sXML & "</" & Trim$(Cells(iCaptionRow, iCOl)) & ">" 
     Next 

     'sXML = sXML & "</row>" 
     Dim nDestFile As Integer, sText As String 

    ''Close any open text files 
     Close 

    ''Get the number of the next free text file 
     nDestFile = FreeFile 
     sOutputFileNamewithPath = sOutputFilePath & sOutputFileName & iCount & ".XML" 
    ''Write the entire file to sText 
     Open sOutputFileNamewithPath For Output As #nDestFile 
     Print #nDestFile, sXML 

     iRow = iRow + 1 
     sXML = "" 
     iCount = iCount + 1 
    Wend 
    'sXML = sXML & "</rows>" 

    Close 
End Sub 
帮助
+0

与Sonata的答案一样:-( – 2018-02-05 16:36:10