domanskiy

Разобрался.

'Читаем данные из XLS файла
Dim connStr, objConn, getNames, inputFile 
inputFile  = test.xls
connStr = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & inputFile & ";Extended Properties=""Excel 12.0 xml;HDR=No;IMEX=2;"";"

Set objConn = CreateObject("ADODB.Connection")
'Open Connection
objConn.open connStr

'Define recordset and SQL query
'тут мы через SQL запрос вытаскиваем данные из ИМЕННЫХ ячеек экселевского файла. Всё это в массив
Set rs = objConn.execute("SELECT * FROM Job,Customer,Prod")

'присваиваем значения переменным из массива
DO WHILE NOT rs.EOF
Job = rs.Fields(0)
Customer = rs.Fields(1)
Prod = rs.Fields(2)
rs.MoveNext
Loop

'Close connection XLS and release objects
objConn.Close
Set rs = Nothing
Set objConn = Nothing

'формируем XML
Dim  rootNode, subNode, xmlDoc, commentItem, Fragment
Set xmlDoc = CreateObject("Msxml2.DOMDocument")
'Создание объявления XML
xmlDoc.appendChild(xmlDoc.createProcessingInstruction("xml", "version='1.0' encoding='utf-8'"))

'Создание корневого элемента
Set rootNode = xmlDoc.CreateElement("JOBS")
xmlDoc.AppendChild rootNode

Set subNode = rootNode.appendChild(xmlDoc.createElement("Job"))
subNode.text = Job

Set subNode = rootNode.appendChild(xmlDoc.createElement("Customer"))
subNode.text = Customer

Set subNode = rootNode.appendChild(xmlDoc.createElement("Prod"))
subNode.text = Prod

'* -- написание XML-файла с отступом для более легкого использования независимо от того, какая программа использовалась для просмотра или редактирования файла -- *'
Dim rdr, wrt, oStream
Set rdr = CreateObject("MSXML2.SAXXMLReader")
Set wrt = CreateObject("MSXML2.MXXMLWriter")

Set oStream = CreateObject("ADODB.STREAM")
oStream.Open
oStream.Charset = "UTF-8"
 
wrt.Indent = True
wrt.Encoding = "UTF-8"
wrt.Output = oStream
Set rdr.ContentHandler = wrt
Set rdr.ErrorHandler = wrt
rdr.Parse xmlDoc
wrt.Flush

'запись xml файла
oStream.SaveToFile "Test.xml", 2

Set rdr = Nothing
Set wrt = Nothing

использовать Vbscript
VBS открывает xls и запускает скрипт из него.

Т.е. человек набирает в ячейке 485, а макрос автоматически подставляет PANTONE 485 C ?
Как это реализуется?
Сейчас у меня макрос запускается через панель запуска макрасов в Экселе.

Сейчас код такой:

Const strFilePath As String = "Y:\TEMP-Shuttle-IN\Blank_v1.xml"



Sub MyXLS2XML()


    Dim arRound As Integer
    Dim objDoc As MSXML2.DOMDocument
    Dim objNode As MSXML2.IXMLDOMNode
    Dim objRoot As MSXML2.IXMLDOMElement
    Dim objElem As MSXML2.IXMLDOMElement
    Dim ar As Variant
    Dim i As Integer
    
'    Для подсчёта новых форм
Dim val As String
Dim val1 As String
Dim r As Range
Dim SummNewForm As Integer
Set r = Range("E13:E22") 'диапазон ячеек
    
'Массив значений для сравнения
Dim MyArray
MyArray = Array("нов", "новая", "нов.")
 

    
    Set objDoc = New DOMDocument
    objDoc.resolveExternals = True
    Set objNode = objDoc.createProcessingInstruction("xml", "version='1.0' encoding='utf-8'")
    Set objNode = objDoc.InsertBefore(objNode, _
    objDoc.ChildNodes.Item(0))
    Set objRoot = objDoc.createElement("JOB")
    Set objDoc.DocumentElement = objRoot
    
      
             Set objElem = objDoc.createElement("JobNamber")
                  objElem.Text = Range("Номер_заказа")
                  objRoot.appendChild objElem
            
             Set objElem = objDoc.createElement("CustomerName")
                  objElem.Text = Range("Заказчик")
                  objRoot.appendChild objElem


             Set objElem = objDoc.createElement("Substrate")
                  objElem.Text = Range("Тип_материала")
                  objRoot.appendChild objElem

             Set objElem = objDoc.createElement("PrintTech")
                  objElem.Text = Range("Способ_печати")
                  objRoot.appendChild objElem

             Set objElem = objDoc.createElement("ICCprof")
                  objElem.Text = Range("ICC_профиль")
                  objRoot.appendChild objElem

             Set objElem = objDoc.createElement("CutTools")
                  objElem.Text = Range("Номер_штампа")
                  objRoot.appendChild objElem

             Set objElem = objDoc.createElement("LabelSize")
                  objElem.Text = Range("Размер_этикетки")
                  objRoot.appendChild objElem

             Set objElem = objDoc.createElement("LabelPart")
                  objElem.Text = Range("часть_этикетки")
                  objRoot.appendChild objElem

             Set objElem = objDoc.createElement("Winding")
                  objElem.Text = Range("Вариант_намотки")
                  objRoot.appendChild objElem

             Set objElem = objDoc.createElement("Designer")
                  objElem.Text = Range("Дизайнер")
                  objRoot.appendChild objElem

          
            
  i = 13
  Do
  
          
        Set objElem = objDoc.createElement("Ink")
            objElem.setAttribute "ID", Cells(i, 1)
            objElem.setAttribute "ColorName", Cells(i, 2)
            objElem.setAttribute "Frequency", Cells(i, 3)
            objElem.setAttribute "Angle", Cells(i, 4)
            objElem.setAttribute "InkParam", Cells(i, 5)
            objRoot.appendChild objElem
            

            
      i = i + 1
 Loop Until Cells(i, 1) = ""
           
'Подсчёт  количества новых форм. по условию val
           
           SummNewForm = Application.WorksheetFunction.CountIf(r, "*" & MyArray(0) & "*")
             Set objElem = objDoc.createElement("SummNewForm")
                  objElem.Text = SummNewForm
                  objRoot.appendChild objElem




            

        
    'Выполнение XSL-преобразования для добавления отступов в XML
    Call transformXML(objDoc)

    objDoc.Save strFilePath

      End Sub

'Процедура для придания XML читабельного вида (с отступами)
Sub transformXML(ByRef objDoc 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>")
    
    'Выполнение преобразования
    objDoc.transformNodeToObject xsl, objDoc

End Sub