Создать xml файл vba excel - Word и Excel - помощь в работе с программами

Краткая справка:

Microsoft Excel — Программа для работы с электронными таблицами. Она предоставляет возможности экономико-статистических расчетов, графические инструменты и язык макропрограммирования VBA (Visual Basic for Application).

Visual Basic for Applications (VBA, Visual Basic для приложений) — немного упрощённая реализация языка программирования Visual Basic, встроенная в линейку продуктов Microsoft Office, а также во многие другие программные пакеты.

XML(англ. eXtensible Markup Language — расширяемый язык разметки). XML — язык с простым формальным синтаксисом, удобный для создания и обработки документов программами и одновременно удобный для чтения и создания документов человеком. Разработчик волен создать разметку в соответствии с потребностями к конкретной области, будучи ограниченным лишь синтаксическими правилами языка.

Задача:

Экспортировать данные из таблицы Excel и сформировать XML-файл с заданной структурой для последующей обработки сторонними программными продуктами.

Исходная таблица с некоторыми данными:

Код VBA:

Sub exportXML()

    'Путь для сохранения итогового XML
    xmlFile = ActiveWorkbook.Path & "export.xml"
    
    'Строка и столбец расположения названия компании
    Dim company_row As Integer
    company_row = 1
    Dim company_col As Integer
    company_col = 1
    
    'Номер строки начала таблицы с данными
    Dim data_row As Integer
    data_row = 3
    
    'Номер столбца "Порядковый номер"
    Dim num_col As Integer
    num_col = 1
    
    'Номер столбца "ФИО"
    Dim name_col As Integer
    name_col = 2
    
    'Номер столбца "Профессия"
    Dim profession_col As Integer
    profession_col = 3
    
    'Номер столбца "Наличность"
    Dim profit_col As Integer
    profit_col = 4


    'Cоздание объекта XML
    Set xml = CreateObject("MSXML2.DOMDocument")
    'Добавление описания XML
    xml.appendChild xml.createProcessingInstruction("xml", "version='1.0' encoding='utf-8'")
    
    'Добавление корневого элемента "company"
    Set Company = xml.createElement("company")
    'Добавление атрибута "name"
    Company.setAttribute "name", Cells(company_row, company_col)
    xml.appendChild (Company)
    
    'Цикл по строкам (пока не встретится строка с пустым "Порядковым номером")
    Do While Not IsEmpty(Cells(data_row, num_col))
       'Вызов функции добавления сотрудника компании
        Company.appendChild (createPerson(xml, Cells(data_row, num_col), _
                               Cells(data_row, name_col), _
                               Cells(data_row, profession_col), _
                               Cells(data_row, profit_col)))
        'Переход к следующей строке таблицы
        data_row = data_row + 1
    Loop
        
    'Выполнение XSL-преобразования для добавления отступов в XML
    Call transformXML(xml)
    
    'Сохранение файла (без выбора пути сохранения, удобно при отладке)
    'xml.Save xmlFile
    'MsgBox "Export complete!"

    'Сохранение файла (с выбором пути сохранения)
    xml.Save Application.GetSaveAsFilename("", "Файл экспорта (*.xml),", , "Введите имя файла", "Сохранить")

End Sub


'Функция добавления сотрудника компании(xml, "Порядковый номер", "ФИО", "Профессия", "Наличность") возвращает узел XML
Function createPerson(ByRef xml As Variant, ByVal num As Variant, ByVal name As Variant, _
                      ByVal profession As Variant, ByVal profit As Variant) As Variant

    'Создание элемента person
    Set createPerson = xml.createElement("person")
    createPerson.setAttribute "num", num
    
    'Добавление в виде комментария "Профессия" (просто для примера)
    createPerson.appendChild (xml.createComment(profession))

    'Создание элементов для столбцов "ФИО" и "Наличность"
    createPerson.appendChild(xml.createElement("name")).Text = name
    createPerson.appendChild(xml.createElement("profit")).Text = profit
    
End Function


'Процедура для придания XML читабельного вида (с отступами)
Sub transformXML(ByRef xml As Variant)

    'Cоздание объекта XSL
    Set xsl = CreateObject("MSXML2.DOMDocument")
    
    'Загрузка XSL из строки (не требует наличия отдельного XSL-файла)
    xsl.LoadXML ("<xsl:stylesheet version='1.0' xmlns:xsl='http://www.w3.org/1999/XSL/Transform'>" & vbCrLf & _
    "<xsl:output method='xml' version='1.0' encoding='UTF-8' indent='yes'/>" & vbCrLf & _
    "<xsl:template match='@*|node()'>" & vbCrLf & _
    "<xsl:copy>" & vbCrLf & _
    "<xsl:apply-templates select='@*|node()' />" & vbCrLf & _
    "</xsl:copy>" & vbCrLf & _
    "</xsl:template>" & vbCrLf & _
    "</xsl:stylesheet>")
    
    'Выполнение преобразования
    xml.transformNodeToObject xsl, xml

End Sub

Результат в виде XML:

<?xml version="1.0" encoding="UTF-8"?>

<company name="ООО 'Рога и копыта'">
	<person num="1">
		<!--Великий комбинатор-->
		<name>Остап Ибрагимович Бендер</name>
		<profit>225000</profit>
	</person>
	<person num="2">
		<!--Нарушитель конвенции-->
		<name>Михаил Самуэлевич Паниковский</name>
		<profit>30000</profit>
	</person>
	<person num="3">
		<!--Водитель автомобиля «Антилопа-Гну»-->
		<name>Адам Казимирович Козлевич</name>
		<profit>95000</profit>
	</person>
	<person num="4">
		<!--Подпольный миллионер-->
		<name>Александр Иванович Корейко</name>
		<profit>1000000</profit>
	</person>
	<person num="5">
		<!--Сын лейтенанта Шмидта-->
		<name>Шура Балаганов</name>
		<profit>50000</profit>
	</person>
</company>

30.07.2015/

https://skynet48.ru/wp-content/uploads/2015/08/Advanced-Excel-VBA-Macros.png
283
343

admin

https://skynet48.ru/wp-content/uploads/2017/04/logo_skynet.png

admin2015-07-30 16:43:312018-06-20 11:41:49Экспорт из Excel в XML с помощью макроса на VBA

Источник

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!

asked May 4, 2010 at 15:40

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:DocsTable1.xml", adPersistXML
End If

rs.Close
cn.Close

answered May 4, 2010 at 17:02

FionnualaFionnuala

90.1k7 gold badges110 silver badges148 bronze badges

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:Usersjlyndsoutput2.xml"
End Sub

indofraiser

9943 gold badges17 silver badges50 bronze badges

answered Mar 13, 2014 at 10:30

SolataSolata

1,3943 gold badges29 silver badges42 bronze badges

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:temptestwb.xlsx")
wb.SaveAs fileName:="C:temptestX.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.

answered Sep 3, 2020 at 8:31

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

answered May 6, 2016 at 7:10

Источник

Download source files — 3.33 KB
Download demo project — 47.41 KB

Introduction

In Excel XP, there is a new export option for XML. However, what I get is many rubbish tags (I’m so disappointed…). Then, after searching on the Google (our nice search engine) for some time about «Converting Excel to XML», what I get are conversion tools that simply make a Rational table to XML. However, what I want is the support of nested structures (e.g. <data><field1>....</field1><data>). As a result, I decided to write my own using VBA… (don’t ask me why VBA… may be I will port it to my favorite C++ platform later.

Using the Code

The source code contains 2 functions GenerateXMLDOM() and fGenerateXML(). They are actually doing the same thing in a different approach.

GenerateXMLDOM — Gives a Microsoft XMLDOM object which you can play with or serialize into an XML at any time using the «Save» method.

fGenerateXML — Generates a long string which is ready for output as file (more readable, as proper newline is added).

Both functions have the same parameters. The first one is rngData, which is the selected table area in the Excel Sheet for conversion. The second (rootNodeName) is the first/root node’s name used in the XML.

In the selected range, the first row is expected to be the field (or node) names. One thing that is worth noticing is that we can use the node name to define the level it belongs to. Started and separated by the node delimiter «/», the node name is one level deeper than the previous one. e.g. /data/field1 is equivalent to <data><field1>....</field1><data>, /student/name/surname is equivalent to <student><name><surname>.... </surname></name></student>:








Function GenerateXMLDOM(rngData As Range, rootNodeName As String)
...


Function fGenerateXML(rngData As Range, rootNodeName As String) As String
...

Limitation and Notes

The ordering of fields may affect the generated XML, fields that have to be placed inside the same sub-node should be placed next to each other. For example, if /student/id and /student/name are placed next to each other, it will generate:

<student><id>..</id><name>...</name></student>

However, if not, the result will be:

<student><id>..</id></student> <somebrabra...> ... </somebrabra...>
<student><name>..</name></student>

The reason is that it only checks with the last field instead of all before deciding where the node should be created.

Finally I would like to thank Hasler Thomas, the author of A Filebrowser for VBA, who provided the code for file browse. Hope this code will be useful for you. Please let me know if there are any bugs.

History

4 May 2004 — First release 0.8 version

Источник

Работа с файлами XML
Массивы

Функция Array2XML формирует из исходной таблицы объект типа DOMDocument, который можно выгрузить в XML-файл одной строкой кода (метод Save)

Sub XMLExport()
    Dim Заголовок As Range, Данные As Range
    Set Заголовок = Range("a1:f1")
    Set Данные = Range([A2], Range("A" & Rows.Count).End(xlUp)).Resize(, Заголовок.Columns.Count)
 
    arrHeaders = Application.Transpose(Application.Transpose(Заголовок.Value))
    ПутьКФайлуXML = ThisWorkbook.Path & "result.xml"
 
    ' формируем DOMDocument, и сохраняем XML в файл result.xml
    Array2XML(Данные.Value, arrHeaders, "Root").Save ПутьКФайлуXML
 
    If Err = 0 Then MsgBox "Создан XML файл" & vbNewLine & ПутьКФайлуXML, vbInformation, "Готово"
End Sub

Код функции Array2XML:

Function Array2XML(ByVal arrData, ByVal arrHeaders, ByVal strHeading$) As DOMDocument
    ' получает в качестве параметров:
    ' двумерный массив arrData с данными для выгрузки,
    ' одномерный массив arrHeaders, содержащий заголовки столбцов,
    ' и strHeading$ - XML-константу объекта
    Dim xmlDoc As DOMDocument, xmlFields As IXMLDOMElement, xmlField As IXMLDOMElement
    Set xmlDoc = CreateObject("Microsoft.XMLDOM")  ' создаём новый DOMDocument

    DataColumnsCount% = UBound(arrData, 2) - LBound(arrData, 2) + 1
    HeadersCount% = UBound(arrHeaders) - LBound(arrHeaders) + 1
    If DataColumnsCount% <> HeadersCount% Then MsgBox "Количество заголовков в массиве arrHeaders" & _
       "не соответствует количеству столбцов массива", vbCritical, "Ошибка создания XML": End
 
    xmlDoc.loadXML Replace("<" + strHeading + "/>", " ", "_")    ' записываем XML-константу объекта

    For i = LBound(arrData) To UBound(arrData)
        ' создание нового узла
        Set xmlFields = xmlDoc.documentElement.appendChild(xmlDoc.createElement("Row"))
 
        For j = LBound(arrHeaders) To UBound(arrHeaders)    ' добавление полей в узел
            Set xmlField = xmlFields.appendChild(xmlDoc.createElement(Replace(arrHeaders(j), " ", "_")))
            xmlField.Text = arrData(i, j + LBound(arrData, 2) - LBound(arrHeaders))
        Next j
    Next i
 
    Set Array2XML = xmlDoc
End Function

Функция нашла применение в программе выгрузки тарифов в XML

27846 просмотров

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.

Источник

Thanks StackOverflow!

asked May 4, 2010 at 15:40

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:DocsTable1.xml", adPersistXML
End If

rs.Close
cn.Close

answered May 4, 2010 at 17:02

FionnualaFionnuala

90.1k7 gold badges110 silver badges148 bronze badges

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:Usersjlyndsoutput2.xml"
End Sub

indofraiser

9943 gold badges17 silver badges50 bronze badges

answered Mar 13, 2014 at 10:30

SolataSolata

1,3943 gold badges29 silver badges42 bronze badges

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:temptestwb.xlsx")
wb.SaveAs fileName:="C:temptestX.xml", FileFormat:= _
        xlXMLSpreadsheet, ReadOnlyRecommended:=False, CreateBackup:=False

End Sub

answered Sep 3, 2020 at 8:31

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

answered May 6, 2016 at 7:10

Источник