Как создать XML из макроса Excel VBA?

Question

Итак, у меня есть куча контента, который был доставлен нам в виде электронных таблиц Excel. Мне нужно взять этот контент и перенести его в другую систему. Другая система берет свои данные из файла XML. Я мог бы сделать все это вручную (и, поверьте, управление не заставит меня это делать!), Но я надеюсь, что есть простой способ написать макрос Excel, который сгенерирует нужный мне XML. Мне кажется, что это лучшее решение, так как эту работу нужно будет регулярно повторять (мы получим много контента на листах Excel), и имеет смысл иметь пакетный инструмент, который сделает это за нас. .

Однако я никогда раньше не экспериментировал с генерацией XML из электронных таблиц Excel. Я немного знаю VBA, но я новичок в XML. Я думаю, моя проблема в поиске в Google заключается в том, что я даже не знаю, для чего Google. Кто-нибудь может дать мне небольшое руководство, чтобы начать? Моя идея звучит как правильный подход к этой проблеме, или я упускаю что-то очевидное?

Спасибо, StackOverflow!

Answer 1

Возможно, вы захотите рассмотреть 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

Answer 2

Кредит: 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

Answer 3

См. Экспорт Excel в XML в VBA для справки.

Answer 4

Это еще одна версия - это поможет в общем

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