Здравствуйте, возникла необходимость конвертации данных из таблицы Excel в XML по схеме (схему приложил), перечитал много информации, понял что реально это сделать макросом, в интернете нашел пример макроса конвертации, попытался переделать макрос под выгрузку моих данных из Excel в XML чтоб выгрузка соответствовала моей схеме XML. Но что-то я видимо не совсем так делаю...
Помогите пожалуйста с макросом..
Помогите пожалуйста с макросом..
Код |
---|
Sub exportXML() 'Путь для сохранения итогового XML xmlFile = ActiveWorkbook.Path & "\export.xml" 'Номер строки начала таблицы с данными Dim data_row As Integer data_row = 2 'Номер столбца "Номер" Dim numer_col As Integer numer_col = 7 'Номер столбца "ДАТА" Dim date_col As Integer date_col = 2 'Номер столбца "КОМПАНИЯ" Dim company_col As Integer company_col = 1 'Номер столбца "От" Dim ot_metki_col As Integer ot_metki_col = 3 'Номер столбца "До" Dim do_metki_col As Integer do_metki_col = 4 'Номер столбца "Код" Dim kod_col As Integer kod_col = 5 'Номер столбца "СТОИМОСТЬ" Dim price_col As Integer price_col = 6 'Номер столбца "Объект" Dim objek_col As Integer objek_col = 8 'Cоздание объекта XML Set xml = CreateObject("MSXML2.DOMDocument") 'Добавление описания XML xml.appendChild xml.createProcessingInstruction("xml", "version='1.0' encoding='windows-1251'") 'Добавление корневого элемента "lgt" Set lgt = xml.createElement("lgt") '''Добавление атрибута "name" ''''company.setAttribute "name", Cells(company_row, company_col) ''''xml.appendChild (company) 'Цикл по строкам (пока не встретится строка с пустой ячейкой "Компания") Do While Not IsEmpty(Cells(data_row, company_col)) 'Вызов функции добавления данных //, num_col lgt.appendChild (createGsp(xml, Cells(data_row, ,) Cells(data_row, numer_col), _ Cells(data_row, date_col), _ Cells(data_row, company_col), _ Cells(data_row, ot_metki_col), _ Cells(data_row, do_metki_col), _ Cells(data_row, kod_col), _ Cells(data_row, price_col), _ Cells(data_row, objek_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 createGsp(ByRef xml As Variant, ByVal num As Variant, ByVal name As Variant, _ ByVal profession As Variant, ByVal profit As Variant) As Variant 'Создание элемента Gsp Set createGsp = xml.createElement("gsp") createGsp.setAttribute "num", num 'Добавление в виде комментария "Профессия" (просто для примера) 'createPerson.appendChild (xml.createComment(profession)) 'Создание элементов для столбцов "Номер", "Дата", "Компания", "От", "До", "Код", "СТОИМОСТЬ", "Объект" createGsp.appendChild(xml.createElement("numer")).Text = numer createGsp.appendChild(xml.createElement("date")).Text = Date createGsp.appendChild(xml.createElement("company")).Text = company createGsp.appendChild(xml.createElement("ot_metki")).Text = ot_metki createGsp.appendChild(xml.createElement("do_metki")).Text = do_metki createGsp.appendChild(xml.createElement("kod")).Text = kod createGsp.appendChild(xml.createElement("price")).Text = Price createGsp.appendChild(xml.createElement("objek")).Text = objek 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='windows-1251' 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 |