Выгрузка из нескольких Excel файлов в один XML (vba макрос)

[Alex_Dom]

Приветствую
Требуется не тривиальная задача: сделать один XML файл из нескольких экселевских.

При этим, в первом файле есть помимо других полей, ID детали
Во втором файле, таблица с данными по столбцам ID: pole1: pole2: pole3

Соответственно в XML файле нужно и ID и подставить соответствующие значения полей

Как это с сделать?

[Aleksandr H.]

Сообщение от Alex_Dom

Как это с сделать?

разбить задачу на подзадачи.
1. Собрать данные на один лист
2. Сформировать ноды xml

[Alex_Dom]

Т.е. сначала VBA который подставит значения, потом выгрузит в XML
Не подкинете пример, как из другого файла с помощью VBA данные подставлять, причём строка выбирается по сопоставлению ID (ID у нас буква+4х значное число) ?

[Aleksandr H.]

Скиньте на почту файлы, посмотрю.

[Alex_Dom]

https://yadi.sk/d/PEEs7Gw6LJF5cw
Два файла.
В бланк должны подставляться данный из базы штампов по названию штампа

[Aleksandr H.]

Открыть Бланк на лист1. Запустить ReadLibrary

Option Explicit

Sub ReadLibrary()
    Dim ofd As FileDialog
    Set ofd = Application.FileDialog(msoFileDialogFilePicker)
    With ofd
        .AllowMultiSelect = False
        .Title = "Select БАЗА ШТАМПОВ file"
        .InitialFileName = ThisWorkbook.Path
        .Filters.Clear
        .Filters.Add "Excel files", "*.xlsx"
        If .Show = -1 Then
            WorkWithLibrary (.SelectedItems(1))
            CreateXML Worksheets(1)
        End If
    End With
End Sub

Private Sub WorkWithLibrary(fileName As String)
    Dim xls As Object
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim ash As Worksheet
    Dim iTotalRows As Integer
    Dim iCnt As Integer
    Dim sId As String
    Dim sParams As String
    Set xls = CreateObject("Excel.Application")
    Set ash = ActiveSheet
    xls.Visible = False
    Set wb = xls.Workbooks.Open(fileName, True, True)
    Set ws = wb.Sheets(1)
    With ws
        iTotalRows = .Cells(.Rows.Count, "A").End(xlUp).Row
        For iCnt = 2 To iTotalRows
            ash.Cells(1, iCnt) = .Cells(iCnt, "A")
            ash.Cells(2, iCnt) = .Cells(iCnt, "B")
            ash.Cells(3, iCnt) = .Cells(iCnt, "C")
            ash.Cells(4, iCnt) = .Cells(iCnt, "D")
        Next iCnt
    End With
    wb.Close False
    xls.Quit
    Set xls = Nothing
    Set ws = Nothing
    Set wb = Nothing
End Sub

Private Sub CreateXML(ws As Worksheet)
    Dim xmlFile As String
    xmlFile = ActiveWorkbook.Path & "\export.xml"
    
    Dim id_row As Integer
    id_row = 1
    
    Dim width_row As Integer
    width_row = 2
    
    Dim height_row As Integer
    height_row = 3
    
    Dim items_row As Integer
    items_row = 3
    
    Dim lilocn_row As Integer
    lilocn_row = 4
    
    Dim xml As Object
    Set xml = CreateObject("MSXML2.DOMDocument")
    xml.appendchild xml.createProcessingINstruction("xml", "version='1.0' encoding='utf-8'")
    Dim Company
    Set Company = xml.createElement("company")
    Company.setAttribute "name", "Alex_Dom"
    xml.appendchild (Company)
    
    Dim data_col As Integer
    data_col = 2
    
    Do While Not IsEmpty(Cells(1, data_col))
        Company.appendchild (createStamp(xml, Cells(id_row, data_col), _
                            Cells(width_row, data_col), _
                            Cells(height_row, data_col), _
                            Cells(items_row, data_col)))
        data_col = data_col + 1
    Loop
    
    Call transformXML(xml)
    
    xml.Save Application.GetSaveAsFilename("", "Export file (*.xml),", , "Input File Name", "Save")
End Sub


Private Function createStamp(ByRef xml As Variant, ByVal sId As Variant, ByVal width As Variant, _
            height As Variant, items As Variant)
    Dim stamp
    Set stamp = xml.createElement("stamp")
    stamp.setAttribute "номер", sId
    stamp.appendchild(xml.createElement("Ширина_штампа")).Text = width
    stamp.appendchild(xml.createElement("Высота_штампа")).Text = height
    stamp.appendchild(xml.createElement("Количество_элементов_на_штампе")).Text = items
    Set createStamp = stamp
End Function

Private Sub transformXML(ByRef xml As Variant)
    Dim xsl
    Set xsl = CreateObject("MSXML2.DOMDocument")
    
    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

[Alex_Dom]

Спасибо. Буду экспериментировать.

[Alex_Dom]

Странно, вместо того что бы подставить только одни значения, вставляются все из файла с базой штампов.
Т.е. если подключить к файлу с базой, с парой сотен штампов, скрипт сделает пару сотен столбцов.
А мне нужно что бы был один столбец со значениями выбранными по имени штампа.
Т.е. A141 написал, запустил скрипт, и он под ним вставляет данные этого штампа из файла/базы

[Alex_Dom]

Можно ли принудительно написать путь к файлу с базой штампов?
Он у меня в конкретном месте и не меняется.

[Aleksandr H.]

Sub ReadLibrary()
    Dim sFilePath As String
    sFilePath = "D:\База штампов.xlsx"
    WorkWithLibrary (sFilePath)
    CreateXML Worksheets(1)
End Sub

Private Sub WorkWithLibrary(fileName As String)
    Dim xls As Object
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim ash As Worksheet
    Dim iTotalRows As Integer
    Dim iCnt As Integer
    Dim iRng As Integer
    Dim sId As String
    Dim sParams As String
    Dim rngInput()
    Set xls = CreateObject("Excel.Application")
    Set ash = ActiveSheet
    xls.Visible = False
    Set wb = xls.Workbooks.Open(fileName, True, True)
    Set ws = wb.Sheets(1)
    With ws
        iTotalRows = .Cells(.Rows.Count, "A").End(xlUp).Row
        rngInput = .Range("A2:D" & iTotalRows).Value2
    End With
    With ash
        iCnt = 2
        Do While .Cells(1, iCnt) <> ""
            For iRng = 1 To UBound(rngInput, 1)
                If rngInput(iRng, 1) = .Cells(1, iCnt) Then
                    .Cells(2, iCnt) = rngInput(iRng, 2)
                    .Cells(3, iCnt) = rngInput(iRng, 3)
                    .Cells(4, iCnt) = rngInput(iRng, 4)
                    Exit For
                End If
            Next iRng
            iCnt = iCnt + 1
        Loop
    End With
    wb.Close False
    xls.Quit
    Set xls = Nothing
    Set ws = Nothing
    Set wb = Nothing
End Sub