vikttur написал: Код в сообщении следует оформлять с помощью кнопки . Вместо выделения цветом достаточно написать: "Заменить везде NodeLocation"
Я что-то в "Microsoft Visual Basic fof Application" - изначально не заметил . Думаю через ( Ctrl+H ) удобнее будет кусок код менять.
Код
Sub Replace_xml()
Dim xmlDoc
Dim iTrek
With Application.FileDialog(msoFileDialogOpen)
If .Show = 0 Then MsgBox "Файл не выбран!", 64, "ошибка": Exit Sub
iTrek = .SelectedItems(1)
End With
Set xmlDoc = CreateObject("Microsoft.XMLDOM")
xmlDoc.async = False
xmlDoc.validateOnParse = False
strFilePath = iTrek
xmlDoc.Load (strFilePath)
Dim objListOfNodes
xmlDoc.setProperty "SelectionLanguage", "XPath"
XPath = "//Start"
Set objListOfNodes = xmlDoc.SelectNodes(XPath)
For n = 0 To objListOfNodes.Length - 1
Set StartNode = objListOfNodes(n)
StartText = StartNode.Text
If InStr(1, StartText, "-", vbTextCompare) > 0 Then
StartR = Split(StartText, "-")
StartNode.Text = StartR(1) & " " & StartR(0)
End If
Next
XPath = "//End"
Set objListOfNodes = xmlDoc.SelectNodes(XPath)
For n = 0 To objListOfNodes.Length - 1
Set EndNode = objListOfNodes(n)
EndText = EndNode.Text
If InStr(1, EndText, "-", vbTextCompare) > 0 Then
EndR = Split(EndText, "-")
EndNode.Text = EndR(1) & " " & EndR(0)
End If
Next
XPath = "//PI"
Set objListOfNodes = xmlDoc.SelectNodes(XPath)
For n = 0 To objListOfNodes.Length - 1
Set PINode = objListOfNodes(n)
PIText = PINode.Text
If InStr(1, PIText, "-", vbTextCompare) > 0 Then
PIR = Split(PIText, "-")
PINode.Text = PIR(1) & " " & PIR(0)
End If
Next
XPath = "//Center"
Set objListOfNodes = xmlDoc.SelectNodes(XPath)
For n = 0 To objListOfNodes.Length - 1
Set CenterNode = objListOfNodes(n)
CenterText = CenterNode.Text
If InStr(1, CenterText, "-", vbTextCompare) > 0 Then
CenterR = Split(CenterText, "-")
CenterNode.Text = CenterR(1) & " " & CenterR(0)
End If
Next
XPath = "//NodeLocation"
Set objListOfNodes = xmlDoc.SelectNodes(XPath)
For n = 0 To objListOfNodes.Length - 1
Set NodeLocationNode = objListOfNodes(n)
NodeLocationText = NodeLocationNode.Text
If InStr(1, NodeLocationText, "-", vbTextCompare) > 0 Then
NodeLocationR = Split(NodeLocationText, "-")
NodeLocationNode.Text = NodeLocationR(1) & " " & NodeLocationR(0)
End If
Next
XPath = "//Point"
Set objListOfNodes = xmlDoc.SelectNodes(XPath)
For n = 0 To objListOfNodes.Length - 1
Set PointNode = objListOfNodes(n)
PointText = PointNode.Text
If InStr(1, PointText, "-", vbTextCompare) > 0 Then
PointR = Split(PointText, "-")
PointNode.Text = PointR(1) & " " & PointR(0)
End If
Next
xmlDoc.Save strFilePath
End Sub
Вот сам код в друг кому понадобится. при запуске спрашивает где лежит файл и сразу его меняет!!!! Все действия проводите только после создания копии.
Doober, все на английском (английский в школе мимо меня прошел )
Код
Next
XPath = "//NodeLocation"
Set objListOfNodes = xmlDoc.SelectNodes(XPath)
For n = 0 To objListOfNodes.Length - 1
Set NodeLocationNode = objListOfNodes(n)
NodeLocationText = NodeLocationNode.Text
If InStr(1, NodeLocationText, "-", vbTextCompare) > 0 Then
NodeLocationR = Split(NodeLocationText, "-")
NodeLocationNode.Text = NodeLocationR(1) & " " & NodeLocationR(0)
End If
Next
Для каждого элемента надо менять все что красным. А как это делать в пару кликов? а не ручками копи паст?
только я не могу понять как работает скрипт. XPath = "//Start" ( я так понимаю начинает работать с <Start> </Start>)
а вот к примеру есть <Point name="11" cameFromLiveInterop="True" picketage="139 1 64.998" seqNo="11">664538.194 -6159896.711 0</Point> тут достаточно XPath = "//Point" ? и нолик останется на месте?
меня интересует именно <Start>663894.452737859 -6160205.42335494</Start><End>663794.791098493 -6160222.97523945 составил табличку.
не правильные
правильные
663894.452737859 -6160205.42335494
6160205.42335494 663894.452737859
табличка не работает значений много. как с помощью макроса найти значения из правой ячейки и поменять их на значения из левой? или как сделать преобразования значений сразу в правильные. ( оба значения должны быть положительными и их надо поменять местами)
Подскажите еще сама программа от которой файл XML почему то записывает весь код строчку. Хотя везде на форумах и в интернете обычно все разбито на строки. это как то влияет на работу или только для удобства чтения кода?
Feature[2] отличился Feature[3] наверно из за того что разделы удалял чтобы XML сюда подгрузить. Как определить какой будет Feature[?] ну или что в скобках?
( 1,2, Файла я сам конечно могу и отредактировать но надо как то сделать это чудо в Exel чтобы коллегам не нужно было думать как это работает )
Подскажите у меня подобная проблема но структура вроде одна, Есть подраздел в XML в который хочется добавить текст (данные в определенный подраздел) но такой подраздел встречается в других разделах. ( <CustomShiftGates> ..... </CustomShiftGates>) отдельно отредактировать получается через Ноте++ но как это автоматизировать чтобы избежать ошибок. Можно в бить фиктивную запись типа (<CustomShiftGates> <ShiftGate Description="Высокая Платформа" Location="560 9 70.61" RightBound="0" LeftBound="-0.055"/> </CustomShiftGates)
А эк селем найти данный текст и заменить на необходимый и сохранить новым файлом. как реализовать макросом?
Sub XML()
Dim fso As Object
Dim txt As Object
Dim cell As Range
Dim iTrek
With Application.FileDialog(msoFileDialogSaveAs)
If .Show = 0 Then MsgBox "Папка не выбрана!", 64, "ОШИБКА": Exit Sub
iTrek = .SelectedItems(1)
End With
Set fso = CreateObject("Scripting.FileSystemObject")
Set txt = fso.CreateTextFile(iTrek, True, True)
For Each cell In Range("M36")
txt.WriteLine cell
Next
txt.Close
Set txt = Nothing
Set fso = Nothing '''...
End Sub
Всем Спасибо это мой второй макрос. Еще раз скорректировал.
Добрый день. Как прикрутить диалоговое окно в котором я укажу куда сохранять и в каком формате (текст в фале берется из Ячейки)
Скрипт ниже
Код
Sub Primer4()
Dim fso As Object
Dim txt As Object
Dim cell As Range
Set fso = CreateObject("Scripting.FileSystemObject")
Set txt = fso.CreateTextFile("D:\23.xml", True, True)
For Each cell In Range("M36")
txt.WriteLine cell
Next
txt.Close
Set txt = Nothing
Set fso = Nothing '''...
End Sub
Вместо фиксированного места "D:\23.xml" Хотелось бы видеть диалоговое окно предлагающие место для сохранения файла.
Sub XML_Âûãðóçêà()
Dim fso As Object
Dim txt As Object
Dim cell As Range
Set fso = CreateObject("Scripting.FileSystemObject")
Set txt = fso.CreateTextFile("C:\1.XML", True, True)
For Each cell In Range("M36")
txt.WriteLine cell
Next
txt.Close
Set txt = Nothing
Set fso = Nothing
End Sub
Подскажите как сделать что бы Файл вместо пути D:\1.XML,