Ошибка времени выполнения при попытке экспорта данных из XLS в именованный файл XML - PullRequest
Новая
       0

Ошибка времени выполнения при попытке экспорта данных из XLS в именованный файл XML

0 голосов
/ 05 декабря 2018

Я написал свой первый макрос VBA для экспорта строк данных из XLS в отдельные именованные файлы XML в определенном месте.Мои первоначальные упрощенные тесты прошли нормально, но ошибки полной версии с сообщением:

Ошибка времени выполнения 91: переменная объекта или переменная блока не установлена ​​

макрос: 

  Sub XML()
 sTemplateXML = _
"<?xml version='1.0'?>" + vbNewLine + _
 "<FromEmail>" + "</FromEmail>" + vbNewLine + _
 "<FromName>" + "</FromName>" + vbNewLine + _
 "<ToEmail>" + "</ToEmail>" + vbNewLine + _
 "<CCAddresses>" + "</CCAddresses>" + vbNewLine + _
 "<BCCAddresses>" + "</BCCAddresses>" + vbNewLine + _
 "<ReplyTo>" + "</ReplyTo>" + vbNewLine + _
 "<Subject>" + "</Subject>" + vbNewLine + _
 "<Body>" + "</Body>" + vbNewLine + _
 "</EmailValues>" + vbNewLine

 Set doc = CreateObject("MSXML2.DOMDocument")
 doc.async = False
 doc.validateOnParse = False
 doc.resolveExternals = False

With ActiveWorkbook.ActiveSheet
lLastRow = ActiveWorkbook.ActiveSheet.UsedRange.Rows.Count

For lRow = 2 To lLastRow
sFile = ActiveWorkbook.ActiveSheet.Cells(lRow, 13).Value
sfromemail = ActiveWorkbook.ActiveSheet.Cells(lRow, 3).Value
sFromname = ActiveWorkbook.ActiveSheet.Cells(lRow, 2).Value
sToEmail = ActiveWorkbook.ActiveSheet.Cells(lRow, 5).Value
sCCAddresses = ActiveWorkbook.ActiveSheet.Cells(lRow, 7).Value
sBCCAddresses = ActiveWorkbook.ActiveSheet.Cells(lRow, 8).Value
sReplyTo = ActiveWorkbook.ActiveSheet.Cells(lRow, 4).Value
sSubject = ActiveWorkbook.ActiveSheet.Cells(lRow, 11).Value
sBody = ActiveWorkbook.ActiveSheet.Cells(lRow, 12).Value


doc.LoadXML sTemplateXML
doc.getElementsbyTagName("FromEmail")(0).appendChild 
doc.createTextNode(sfromemail) (ERROR POPS UP HERE)
doc.getElementsbyTagName("FromName")(0).appendChild 
doc.createTextNode(sFromname)
doc.getElementsbyTagName("ToEmail")(0).appendChild 
doc.createTextNode(sToEmail)
doc.getElementsbyTagName("CCAddresses")(0).appendChild 
doc.createTextNode(sCCAddresses)
doc.getElementsbyTagName("BCCAddresses")(0).appendChild 
doc.createTextNode(sBCCAddresses)
doc.getElementsbyTagName("ReplyTo")(0).appendChild 
doc.createTextNode(sReplyTo)
doc.getElementsbyTagName("Subject")(0).appendChild 
doc.createTextNode(sSubject)
doc.getElementsbyTagName("Body")(0).appendChild doc.createTextNode(sBody)

doc.Save sFile
Next

End With
End Sub

1 Ответ

0 голосов
/ 06 декабря 2018

Может быть намного аккуратнее с небольшим рефакторингом: 

Sub SaveRowsToXml()
    Dim lLastRow As Long, lrow As Long
    With ActiveWorkbook.ActiveSheet
        lLastRow = .UsedRange.Rows.Count
        For lrow = 2 To lLastRow
            SaveToXml .Rows(lrow)
        Next lrow
    End With
End Sub

'save a single row of data as XML
Sub SaveToXml(rw As Range)
    Dim doc As Object, r
    Set doc = CreateObject("MSXML2.DOMDocument")
    doc.appendChild doc.createProcessingInstruction("xml", "version='1.0'")
    Set r = doc.createElement("EmailValues") '<< create the root element
    doc.appendChild r
    'append child nodes
    r.appendChild NodeWithContent(doc, "FromEmail", rw.Cells(3).Value)
    r.appendChild NodeWithContent(doc, "FromName", rw.Cells(2).Value)
    r.appendChild NodeWithContent(doc, "ToEmail", rw.Cells(5).Value)
    r.appendChild NodeWithContent(doc, "CCAddresses", rw.Cells(7).Value)
    'etc
    'etc
    'Debug.Print doc.XML
    doc.Save rw.Cells(13).Value
    Set doc = Nothing
End Sub

'return a named element with content
Function NodeWithContent(doc, nodename, content)
    Dim el
    Set el = doc.createElement(nodename)
    el.appendChild doc.createTextNode(content)
    Set NodeWithContent = el
End Function
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Нет похожих вопросов

...