Добрый день! Помогите, пожалуйста. Нужно: Либо объединить кучу xml в один сразу пачкой Либо конвертировать xml в xls тоже пачкой. Приложены два файла-примера. В реальности таких файлов может быть сотни
Добрый день! Помогите, пожалуйста. Нужно: Либо объединить кучу xml в один сразу пачкой Либо конвертировать xml в xls тоже пачкой. Приложены два файла-примера. В реальности таких файлов может быть сотниAVI
Sub MergeXml() Set xmlDoc = CreateObject("Microsoft.XMLDOM") Set objNode = xmlDoc.createProcessingInstruction( _ "xml", "version=""1.0"" encoding=""utf-8""") Set objNode = xmlDoc.InsertBefore(objNode, xmlDoc.ChildNodes.Item(0)) Set objNode = xmlDoc.createProcessingInstruction( _ "xml-stylesheet", "type=""text/xsl"" href=""https://portal.rosreestr.ru/xsl/EGRP/Reestr_Extract_Gkn/OKS/07/Common.xsl""") Set objNode = xmlDoc.InsertBefore(objNode, xmlDoc.ChildNodes.Item(1)) Set objRoot = xmlDoc.createElement("root") xmlDoc.appendChild objRoot Items = Get_Item("C:\00") For n = 0 To UBound(Items) With CreateObject("Microsoft.XMLDOM") .Load (Items(n)) Set KPOKS = .SelectSingleNode("//KPOKS") If Not KPOKS Is Nothing Then objRoot.appendChild KPOKS End If
End With Next xmlDoc.Save ("C:\all.xml") Set xmlDoc = Nothing End Sub Function Get_Item(Path)
Set C_is = CreateObject("scripting.dictionary") Set oFSO = CreateObject("Scripting.FileSystemObject") Dim strFile As String Set FSO = CreateObject("scripting.filesystemobject") Set curfold = FSO.GetFolder(Path) If Not curfold Is Nothing Then For Each fil In curfold.Files
If InStr(1, fil.Name, ".xml", vbTextCompare) > 0 Then strFile = fil.Path C_is.Item(strFile) = strFile End If Next
End If Set FSO = Nothing Get_Item = C_is.Keys End Function
[/vba]
Здравствуйте.Пример рабочий
[vba]
Код
Sub MergeXml() Set xmlDoc = CreateObject("Microsoft.XMLDOM") Set objNode = xmlDoc.createProcessingInstruction( _ "xml", "version=""1.0"" encoding=""utf-8""") Set objNode = xmlDoc.InsertBefore(objNode, xmlDoc.ChildNodes.Item(0)) Set objNode = xmlDoc.createProcessingInstruction( _ "xml-stylesheet", "type=""text/xsl"" href=""https://portal.rosreestr.ru/xsl/EGRP/Reestr_Extract_Gkn/OKS/07/Common.xsl""") Set objNode = xmlDoc.InsertBefore(objNode, xmlDoc.ChildNodes.Item(1)) Set objRoot = xmlDoc.createElement("root") xmlDoc.appendChild objRoot Items = Get_Item("C:\00") For n = 0 To UBound(Items) With CreateObject("Microsoft.XMLDOM") .Load (Items(n)) Set KPOKS = .SelectSingleNode("//KPOKS") If Not KPOKS Is Nothing Then objRoot.appendChild KPOKS End If
End With Next xmlDoc.Save ("C:\all.xml") Set xmlDoc = Nothing End Sub Function Get_Item(Path)
Set C_is = CreateObject("scripting.dictionary") Set oFSO = CreateObject("Scripting.FileSystemObject") Dim strFile As String Set FSO = CreateObject("scripting.filesystemobject") Set curfold = FSO.GetFolder(Path) If Not curfold Is Nothing Then For Each fil In curfold.Files
If InStr(1, fil.Name, ".xml", vbTextCompare) > 0 Then strFile = fil.Path C_is.Item(strFile) = strFile End If Next
End If Set FSO = Nothing Get_Item = C_is.Keys End Function
xmlDoc.Save ("C:\all.xml") Название папки скопировал прямо из макроса
Алексей, название какой папки? "C:\all.xml" переводится как Диск С, файл all.xml Файл all.xml создается прямо на диске С. Скорее всего у Вас просто нет доступа к нему Попробуйте вот так [vba]
xmlDoc.Save ("C:\all.xml") Название папки скопировал прямо из макроса
Алексей, название какой папки? "C:\all.xml" переводится как Диск С, файл all.xml Файл all.xml создается прямо на диске С. Скорее всего у Вас просто нет доступа к нему Попробуйте вот так [vba]
Код
xmlDoc.Save ("C:\00\all.xml")
[/vba] Файл all.xml появится в той же папке "00"_Boroda_
Доброго времени суток! Пытаюсь выше указанным VBA объединить xml в итоге появляется общий файл, но он пустой. Подскажите, что делаю не так! xml по 5 мб.
Доброго времени суток! Пытаюсь выше указанным VBA объединить xml в итоге появляется общий файл, но он пустой. Подскажите, что делаю не так! xml по 5 мб.AlekseyU
Добрый день! Понадобилось вновь воспользоваться указанным макросом:
[vba]
Код
Sub MergeXml() Set xmlDoc = CreateObject("Microsoft.XMLDOM") Set objNode = xmlDoc.createProcessingInstruction( _ "xml", "version=""1.0"" encoding=""utf-8""") Set objNode = xmlDoc.InsertBefore(objNode, xmlDoc.ChildNodes.Item(0)) Set objNode = xmlDoc.createProcessingInstruction( _ "xml-stylesheet", "type=""text/xsl"" href=""https://portal.rosreestr.ru/xsl/EGRP/Reestr_Extract_Gkn/OKS/07/Common.xsl""") Set objNode = xmlDoc.InsertBefore(objNode, xmlDoc.ChildNodes.Item(1)) Set objRoot = xmlDoc.createElement("root") xmlDoc.appendChild objRoot Items = Get_Item("F:\Excel\Фонд\Объединение XML\Исходники") For n = 0 To UBound(Items) With CreateObject("Microsoft.XMLDOM") .Load (Items(n)) Set Extract = .SelectSingleNode("//Extract") If Not Extract Is Nothing Then objRoot.appendChild Extract End If
End With Next xmlDoc.Save ("F:\Excel\Фонд\Объединение XML\Исходники\Gotov.xml") Set xmlDoc = Nothing End Sub Function Get_Item(Path)
Set C_is = CreateObject("scripting.dictionary") Set oFSO = CreateObject("Scripting.FileSystemObject") Dim strFile As String Set FSO = CreateObject("scripting.filesystemobject") Set curfold = FSO.GetFolder(Path) If Not curfold Is Nothing Then For Each fil In curfold.Files
If InStr(1, fil.Name, ".xml", vbTextCompare) > 0 Then strFile = fil.Path C_is.Item(strFile) = strFile End If Next
End If Set FSO = Nothing Get_Item = C_is.Keys End Function
[/vba]
но готовый файл оказался пустым и совсем не xls Не могли бы вы помочь разобраться почему так. Видимо, что-то в XMLях поменялось? Понимаю, что иногда проще сделать самому, чем разбираться в чужих маркосах, поэтому думал создать новую тему. Как сделать правильно-то? Запилить новую тему?
Добрый день! Понадобилось вновь воспользоваться указанным макросом:
[vba]
Код
Sub MergeXml() Set xmlDoc = CreateObject("Microsoft.XMLDOM") Set objNode = xmlDoc.createProcessingInstruction( _ "xml", "version=""1.0"" encoding=""utf-8""") Set objNode = xmlDoc.InsertBefore(objNode, xmlDoc.ChildNodes.Item(0)) Set objNode = xmlDoc.createProcessingInstruction( _ "xml-stylesheet", "type=""text/xsl"" href=""https://portal.rosreestr.ru/xsl/EGRP/Reestr_Extract_Gkn/OKS/07/Common.xsl""") Set objNode = xmlDoc.InsertBefore(objNode, xmlDoc.ChildNodes.Item(1)) Set objRoot = xmlDoc.createElement("root") xmlDoc.appendChild objRoot Items = Get_Item("F:\Excel\Фонд\Объединение XML\Исходники") For n = 0 To UBound(Items) With CreateObject("Microsoft.XMLDOM") .Load (Items(n)) Set Extract = .SelectSingleNode("//Extract") If Not Extract Is Nothing Then objRoot.appendChild Extract End If
End With Next xmlDoc.Save ("F:\Excel\Фонд\Объединение XML\Исходники\Gotov.xml") Set xmlDoc = Nothing End Sub Function Get_Item(Path)
Set C_is = CreateObject("scripting.dictionary") Set oFSO = CreateObject("Scripting.FileSystemObject") Dim strFile As String Set FSO = CreateObject("scripting.filesystemobject") Set curfold = FSO.GetFolder(Path) If Not curfold Is Nothing Then For Each fil In curfold.Files
If InStr(1, fil.Name, ".xml", vbTextCompare) > 0 Then strFile = fil.Path C_is.Item(strFile) = strFile End If Next
End If Set FSO = Nothing Get_Item = C_is.Keys End Function
[/vba]
но готовый файл оказался пустым и совсем не xls Не могли бы вы помочь разобраться почему так. Видимо, что-то в XMLях поменялось? Понимаю, что иногда проще сделать самому, чем разбираться в чужих маркосах, поэтому думал создать новую тему. Как сделать правильно-то? Запилить новую тему?AVI
Откройте файл для посмотреть и Вы снова увидите там КРОКС. Вывод - используйте первый код или перепишите его так, чтобы он работал для обоих вариантов И почему Вы хотите xls, если сами пишете в макросе
Я в этом ничего не понимаю и не знаю, могут ли быть еще варианты корневых элементов, поэтому написал только для двух Пути перепишите свои
[vba]
Код
Sub MergeXml() Set xmlDoc = CreateObject("Microsoft.XMLDOM") Set objNode = xmlDoc.createProcessingInstruction("xml", "version=""1.0"" encoding=""utf-8""") Set objNode = xmlDoc.InsertBefore(objNode, xmlDoc.ChildNodes.Item(0)) Set objNode = xmlDoc.createProcessingInstruction( _ "xml-stylesheet", "type=""text/xsl"" href=""https://portal.rosreestr.ru/xsl/EGRP/Reestr_Extract_Gkn/OKS/07/Common.xsl""") Set objNode = xmlDoc.InsertBefore(objNode, xmlDoc.ChildNodes.Item(1)) Set objRoot = xmlDoc.createElement("root") xmlDoc.appendChild objRoot Items = Get_Item("g:\Моя\Стереть\22\") For n = 0 To UBound(Items) With CreateObject("Microsoft.XMLDOM") .Load (Items(n)) Set KPOKS = .SelectSingleNode("//KPOKS") If KPOKS Is Nothing Then Set KPOKS = .SelectSingleNode("//Extract") End If If Not KPOKS Is Nothing Then objRoot.appendChild KPOKS End If End With Next xmlDoc.Save ("g:\Моя\Стереть\22\all.xls") Set xmlDoc = Nothing End Sub Function Get_Item(Path) Set C_is = CreateObject("scripting.dictionary") Set oFSO = CreateObject("Scripting.FileSystemObject") Dim strFile As String Set FSO = CreateObject("scripting.filesystemobject") Set curfold = FSO.GetFolder(Path) If Not curfold Is Nothing Then For Each fil In curfold.Files If InStr(1, fil.Name, ".xml", vbTextCompare) > 0 Then strFile = fil.Path C_is.Item(strFile) = strFile End If Next End If Set FSO = Nothing Get_Item = C_is.Keys End Function
[/vba]
Откройте файл для посмотреть и Вы снова увидите там КРОКС. Вывод - используйте первый код или перепишите его так, чтобы он работал для обоих вариантов И почему Вы хотите xls, если сами пишете в макросе
Я в этом ничего не понимаю и не знаю, могут ли быть еще варианты корневых элементов, поэтому написал только для двух Пути перепишите свои
[vba]
Код
Sub MergeXml() Set xmlDoc = CreateObject("Microsoft.XMLDOM") Set objNode = xmlDoc.createProcessingInstruction("xml", "version=""1.0"" encoding=""utf-8""") Set objNode = xmlDoc.InsertBefore(objNode, xmlDoc.ChildNodes.Item(0)) Set objNode = xmlDoc.createProcessingInstruction( _ "xml-stylesheet", "type=""text/xsl"" href=""https://portal.rosreestr.ru/xsl/EGRP/Reestr_Extract_Gkn/OKS/07/Common.xsl""") Set objNode = xmlDoc.InsertBefore(objNode, xmlDoc.ChildNodes.Item(1)) Set objRoot = xmlDoc.createElement("root") xmlDoc.appendChild objRoot Items = Get_Item("g:\Моя\Стереть\22\") For n = 0 To UBound(Items) With CreateObject("Microsoft.XMLDOM") .Load (Items(n)) Set KPOKS = .SelectSingleNode("//KPOKS") If KPOKS Is Nothing Then Set KPOKS = .SelectSingleNode("//Extract") End If If Not KPOKS Is Nothing Then objRoot.appendChild KPOKS End If End With Next xmlDoc.Save ("g:\Моя\Стереть\22\all.xls") Set xmlDoc = Nothing End Sub Function Get_Item(Path) Set C_is = CreateObject("scripting.dictionary") Set oFSO = CreateObject("Scripting.FileSystemObject") Dim strFile As String Set FSO = CreateObject("scripting.filesystemobject") Set curfold = FSO.GetFolder(Path) If Not curfold Is Nothing Then For Each fil In curfold.Files If InStr(1, fil.Name, ".xml", vbTextCompare) > 0 Then strFile = fil.Path C_is.Item(strFile) = strFile End If Next End If Set FSO = Nothing Get_Item = C_is.Keys End Function