Code: Select all
Sub ExportXML()
Dim outPATH As String, LR As Long, Rw As Long, fNAME As String, Str As String
Dim xmlDoc As Object
outPATH = ThisWorkbook.Path & "\XML\"
On Error Resume Next
MkDir outPATH
On Error GoTo 0
Set xmlDoc = CreateObject("MSXML2.DOMDocument")
LR = Range("A" & Rows.Count).End(xlUp).Row
For Rw = 2 To LR
fNAME = Trim(Cells(Rw, "M").Value) & ".xml"
Str = ""
' Open outPATH & fNAME For Output As 1
Str = "<?xml version=""1.0"" encoding=""UTF-8""?>" & vbLf
Str = Str & "<Call xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"">" & vbLf
Str = Str & " <Data>" & vbLf & " <set_aud>" & vbLf & " <connection>" & vbLf
Str = Str & " <messagetype>" & Cells(Rw, "A").Value & "</messagetype>" & vbLf
Str = Str & " <order>" & Cells(Rw, "B").Value & "</order>" & vbLf
Str = Str & " <storage>" & Cells(Rw, "C").Value & "</storage>" & vbLf
Str = Str & " <time_stamp>" & Cells(Rw, "D").Value & "</time_stamp>" & vbLf
Str = Str & " </connection>" & vbLf & " </set_aud>" & vbLf
Str = Str & " <interaction>" & Cells(Rw, "E").Value & "</interaction>" & vbLf
Str = Str & " <dir>" & Cells(Rw, "F").Value & "</dir>" & vbLf
Str = Str & " <hold>" & Cells(Rw, "G").Value & "</hold>" & vbLf
Str = Str & " <conference>" & Cells(Rw, "H").Value & "</conference>" & vbLf
Str = Str & " <duration>" & Format(Cells(Rw, "I").Value, "hh:mm:ss") & "</duration>" & vbLf
Str = Str & " <extension>" & Cells(Rw, "J").Value & "</extension>" & vbLf
Str = Str & " <offset>" & Cells(Rw, "K").Value & "</offset>" & vbLf
Str = Str & " <login>" & Cells(Rw, "L").Value & "</login>" & vbLf
Str = Str & " <agent_name>" & Cells(Rw, "M").Value & "</agent_name>" & vbLf
Str = Str & " <group_name>" & Cells(Rw, "N").Value & "</group_name>" & vbLf
Str = Str & " <ani>" & Cells(Rw, "O").Value & "</ani>" & vbLf
Str = Str & " <dnis>" & Cells(Rw, "P").Value & "</dnis>" & vbLf
Str = Str & " <ani1>" & Cells(Rw, "Q").Value & "</ani1>" & vbLf
Str = Str & " </Data>" & vbLf & " <Other>" & vbLf
Str = Str & " <c02>" & Cells(Rw, "R").Value & "</c02>" & vbLf
Str = Str & " <c03>" & Cells(Rw, "S").Value & "</c03>" & vbLf
Str = Str & " <c01>" & Cells(Rw, "T").Value & "</c01>" & vbLf
Str = Str & " <c04>" & Cells(Rw, "U").Value & "</c04>" & vbLf
Str = Str & " <c05>" & Cells(Rw, "V").Value & "</c05>" & vbLf
Str = Str & " <c06>" & Cells(Rw, "W").Value & "</c06>" & vbLf
Str = Str & " <c07>" & IIf(Cells(Rw, "X") > 0, Cells(Rw, "X").Value, "") & "</c07>" & vbLf
Str = Str & " <c08>" & IIf(Cells(Rw, "Y") > 0, Cells(Rw, "Y").Value, "") & "</c08>" & vbLf
Str = Str & " <c09>" & IIf(Cells(Rw, "Z") > 0, Cells(Rw, "Z").Value, "") & "</c09>" & vbLf
Str = Str & " <c10>" & IIf(Cells(Rw, "AA") > 0, Cells(Rw, "AA").Value, "") & "</c10>" & vbLf
Str = Str & " <c11>" & IIf(Cells(Rw, "AB") > 0, Cells(Rw, "AB").Value, "") & "</c11>" & vbLf
Str = Str & " <c12>" & IIf(Cells(Rw, "AC") > 0, Cells(Rw, "AC").Value, "") & "</c12>" & vbLf
Str = Str & " <c13>" & IIf(Cells(Rw, "AD") > 0, Cells(Rw, "AD").Value, "") & "</c13>" & vbLf
Str = Str & " <c14>" & IIf(Cells(Rw, "AE") > 0, Cells(Rw, "AE").Value, "") & "</c14>" & vbLf
Str = Str & " <c15>" & IIf(Cells(Rw, "AF") > 0, Cells(Rw, "AF").Value, "") & "</c15>" & vbLf
Str = Str & " <c16>" & IIf(Cells(Rw, "AG") > 0, Cells(Rw, "AG").Value, "") & "</c16>" & vbLf
Str = Str & " </Other>" & vbLf & "</Call>" & vbLf
' Print #1, Str
' Close #1
With xmlDoc
.async = False
.validateOnParse = False
.resolveExternals = False
End With
If Not xmlDoc.LoadXML(Str) Then
With xmlDoc.parseError
MsgBox "Error: " & .ErrorCode & vbCrLf & .reason, vbCritical, "Error"
Exit Sub
End With
End If
xmlDoc.Save outPATH & fNAME
Next Rw
End Sub