如何从 Excel VBA 宏生成 XML？

Question

So, I've got a bunch of content that was delivered to us in the form of Excel spreadsheets. I need to take that content and push it into another system. The other system takes its input from an XML file. I could do all of this by hand (and trust me, management has no problem making me do that!), but I'm hoping there's an easy way to write an Excel macro that would generate the XML I need instead. This seems like a better solution to me, as this is a job that will need to be repeated regularly (we'll be getting a LOT of content in Excel sheets) and it just makes sense to have a batch tool that does it for us.

However, I've never experimented with generating XML from Excel spreadsheets before. I have a little VBA knowledge but I'm a newbie to XML. I guess my problem in Googling this is that I don't even know what to Google for. Can anyone give me a little direction to get me started? Does my idea sound like the right way to approach this problem, or am I overlooking something obvious?

Thanks StackOverflow!

Answer 1

You might like to consider ADO - a worksheet or range can be used as a table.

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

Answer 2

Credit to: curiousmind.jlion.com/exceltotextfile (Link no longer exists)

Script:

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

Answer 3

请参阅在VBA中将Excel导出到XML以获取帮助。

Answer 4

Here is the example macro to convert the Excel worksheet to XML file.

#'vba code to convert excel to xml

Sub vba_code_to_convert_excel_to_xml()
Set wb = Workbooks.Open("C:\temp\testwb.xlsx")
wb.SaveAs fileName:="C:\temp\testX.xml", FileFormat:= _
        xlXMLSpreadsheet, ReadOnlyRecommended:=False, CreateBackup:=False

End Sub

This macro will open an existing Excel workbook from the C drive and Convert the file into XML and Save the file with .xml extension in the specified Folder. We are using Workbook Open method to open a file. SaveAs method to Save the file into destination folder. This example will be help full, if you wan to convert all excel files in a directory into XML (xlXMLSpreadsheet format) file.

Answer 5

This one more version - this will help in generic

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