макрос, извлекающий значения из документа *.xml

[Molotoklk]

Здравствуйте,
есть задача создать реестр из кучи документов .xml со значениями из нескольких параметров. чтобы не копировать каждое надо написать макрос, который бы вытаскивал необходимые значения из указанного .xml-файла и вставлял их в таблицу. предположительно это должно выглядеть в следующей форме: в столбце А указывается путь к xml, из которого будет заполнятся соответствующая ячейке строка таблицы.
Версия Excel -2010.
Подскажите пожалуйста, как это реализовать, заранее спасибо

[EducatedFool]

Если вы спрашиваете, как это сделать, - наверняка, сами не справитесь.
Хотя, сложного ничего нет, если искать готовые примеры, и пытаться переделать их под свою задачу.

Алгоритм макроса:
1) перебираем в цикле все заполненные ячейки столбца A
2) для каждой ячейки производится поиск поиск файла XML по указанному пути
3) если файл найден, функцией-парсером выдираем из него нужные значения
4) заносим значения в ячейки правее текущей.

Более подробно написать - без ваших файлов никак не получится.
Примеров кода цикла на форуме множество.
Примеры парсеров XML тоже попадаются, но значительно реже.

Пример парсера XML можно поглядеть здесь:
http://excelvba.ru/programmes/Parser/samples/XML_parser

Могу настроить под заказ парсер любых XML файлов с выводом в Excel

[Molotoklk]

тогда пойдем от общего к частному, немного упростим задачу вот прикладываю файл из которого надо вытащить информацию:
например параметр <ReferenceMark> из него, чтобы в ячейке из колонки В было "Воронежская область Кантемировский район, северная часть кадастрового квартала 36:12:61 00016",
<Note> - в С "обл. Воронежская, р-н Кантемировский, с. Писаревка" и т.п.,
подскажите, какие функции для этого можно использовать в VBА?

[Казанский]

Основная проблема - перекодировать UTF-8 в Unicode. Однако, нужную функцию нашел быстро. Пробуйте - выбирайте группу файлов с помощью Ctrl и Shift, как обычно:

[Hugo121]

Алексей, как оказалось, можно и без перекодировки.
начало позаимствовал - лениво своё писать...
Но важно - тут теги нужно писать корректно, регистр важен!

Option Explicit

'http://www.xmlfiles.com/dom/dom_access.asp

Sub GetXML()
Dim arFiles, x, b() As Byte, lRow&, c As Range
arFiles = Application.GetOpenFilename("XML files,*.xml", , "Āūįåščņå ōąéėū", , True)
If Not IsArray(arFiles) Then Exit Sub
lRow = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count
For Each x In arFiles
    For Each c In [b1:e1].SpecialCells(xlCellTypeConstants)
        Cells(lRow, c.Column) = FindTag(x, (c))
    Next
    lRow = lRow + 1
Next
End Sub


Private Function FindTag$(ByRef ff, ByRef sTag$)

With CreateObject("Microsoft.XMLDOM")
.async = "false"
.Load (ff)
FindTag = .getElementsByTagName(sTag).Item(0).Text
End With

End Function

[doober]

и проблем с кодировкой нет

Function Read_t()
Dim sXpath As String
 sXpath = "//ReferenceMark"
 sFile = "C:\kv_051101036000_051106036012_36_12_25052011_0000000000.xml"

  With CreateObject("MSXML2.DOMDocument")
   .Load sFile
      Read_t = .DocumentElement.SelectNodes(sXpath)(0).nodeTypedValue
  End With
End Function

[Казанский]

Да, видать, придется изучать объекты для работы с XML. Этого дерьма вокруг все больше

[EducatedFool]

Впрочем, такие файлы XML можно обрабатывать и как обычные таблицы Excel,
открывая их таким кодом:

Sub Макрос1()
    Application.DisplayAlerts = False
    Workbooks.OpenXML Filename:="C:\ПутьКФайлу\kv_имя_файла.xml", LoadOption:=xlXmlLoadImportToList
End Sub

[doober]

Но в этом файле только один нод ReferenceMark
з ачем Excel напрягать

[Molotoklk]

Получается вытащить некоторые параметры, но они заполняются в выбранную ячейку без разделения по столбцам, как это исправить?
(Сделали кнопку, которая выбирает путь к нужному файлу)

Private Sub CommandButton1_Click()

ИмяФайла = GetFilePath() ' запрашиваем имя файла
If ИмяФайла = "" Then Exit Sub ' выход, если пользователь отказался от выбора файла
MsgBox "Выбран файл: " & ИмяФайла, vbInformation

MyMacro (ИмяФайла)

End Sub
Private Sub Frame1_Click()

End Sub
Private Sub UserForm_Click()

End Sub


основной код:

Public Function ImportXML(xmlFileName As String, _
Optional objectPath As String = "*", _
Optional propertyPath As String = "*", _
Optional baseCell As Range = Nothing) As DOMDocument
' Экспорт данных из XML-файла
' 1. формируется DOMDocument объект (ImportXML)
' 2. По заданным параметрам данные из объекта
' переписываются в рабочую книгу
' ПАРАМЕТРЫ:
' xmlFileName - исходный XML-файла
' baseCell - исходный диапазон ячеек
' objectPath - строка запроса (queryString) на выборку узлов
' propertyPath - строка запроса (queryString) на выборку свойств
'
Dim xmlDoc As DOMDocument
Dim objectNodeList As IXMLDOMNodeList
Dim objectNode As IXMLDOMElement
Dim propertyNode As IXMLDOMElement
Dim baseRow&, baseCol&, rowIndex&, colIndex&

' координаты ячеек, куда будем записывать
If baseCell Is Nothing Then 'установка по умолчанию
Set baseCell = ActiveCell
End If
baseRow = baseCell.Row
baseCol = baseCell.Column

' создание DOMDocument объекта
Set xmlDoc = New DOMDocument
xmlDoc.Load xmlFileName ' загрузка XML-файла
' Перезапись данный в таблицу рабочей книги
' выбор узла
Set objectNodeList = xmlDoc.DocumentElement.SelectNodes( objectPath)
If objectNodeList.Length > 0 Then
colIndex = 0
' формирование заголовка таблицы
Set objectNode = objectNodeList(0)
For Each propertyNode In _
objectNode.SelectNodes(propertyPath )
ActiveSheet.Cells(baseRow, baseCol + colIndex).Value = _
propertyNode.nodeName
colIndex = colIndex + 1
Next
' выделение заголовка таблицы (первой строки) жирным шрифтом
ActiveSheet.Range(Cells(baseRow, _
baseCol), Cells(baseRow, baseCol + _
colIndex)).Font.Bold = True
' выборка всех остальных строк таблицы
rowIndex = 1
For Each objectNode In objectNodeList ' все узлы
colIndex = 0
For Each propertyNode In _
objectNode.SelectNodes(propertyPath )
ActiveSheet.Cells(baseRow + rowIndex, _
baseCol + colIndex).Value = _
propertyNode.Text
colIndex = colIndex + 1
Next
rowIndex = rowIndex + 1
Next
End If
Set ImportXML = xmlDoc ' созданный DOMDocument
End Function

Sub MyMacro(ИмяФайла As String)
Set mXML = ImportXML(ИмяФайла)
End Sub
Function GetFilePath(Optional ByVal Title As String = "Выберите файл для обработки", _
Optional ByVal InitialPath As String = "c:\", _
Optional ByVal FilterDescription As String = "Файлы XML", _
Optional ByVal FilterExtention As String = "*.xml*") As String
' функция выводит диалоговое окно выбора файла с заголовком Title,
' начиная обзор диска с папки InitialPath
' возвращает полный путь к выбранному файлу, или пустую строку в случае отказа от выбора
' для фильтра можно указать описание и расширение выбираемых файлов
On Error Resume Next
With Application.FileDialog(msoFileDialo gOpen)
.ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
.Filters.Clear: .Filters.Add FilterDescription, FilterExtention
If .Show <> -1 Then Exit Function
GetFilePath = .SelectedItems(1): PS = Application.PathSeparator
End With
End Function