VBA XML Parsing question

Firstartemis

New Member
Joined
Jun 17, 2015
Messages
10
Good Morning,

Thanks to the help of this board and google, I have been able to write the below macro in excel:

Code:
Sub GetFormData()
        Dim XDoc As MSXML2.DOMDocument
        Dim xEmpDetails As MSXML2.IXMLDOMNode
        Dim xEmployee As MSXML2.IXMLDOMNode
        Dim xChild As MSXML2.IXMLDOMNode
        Dim strFolder As String, strFile As String
        Dim WkSht As Worksheet, i As Long, j As Long
            strFolder = GetFolder
            If strFolder = "" Then Exit Sub
            Set WkSht = ActiveSheet
            i = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row

            strFile = Dir(strFolder & "\*.xfdf", vbNormal)
        While strFile <> ""
                i = i + 1

        Set XDoc = New MSXML2.DOMDocument
        XDoc.async = False
        XDoc.validateOnParse = False
        XDoc.Load (strFolder & "\" & strFile)
        Set xEmpDetails = XDoc.DocumentElement
        Set xEmployee = xEmpDetails.FirstChild
        j = 0
        For Each xEmployee In xEmpDetails.ChildNodes
        For Each xChild In xEmployee.ChildNodes
        j = j + 1
        WkSht.Cells(i, j) = xChild.Text
        Next xChild
        Next xEmployee

        strFile = Dir()
         Wend
        Application.ScreenUpdating = True

Dim sht As Worksheet
Dim fnd As Variant
Dim rplc As Variant

fnd = "Off"
rplc = ""

For Each sht In ActiveWorkbook.Worksheets
  sht.Cells.Replace what:=fnd, Replacement:=rplc, _
    LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
    SearchFormat:=False, ReplaceFormat:=False
Next sht
fnd = "Please type your comments here:"
rplc = ""

For Each sht In ActiveWorkbook.Worksheets
  sht.Cells.Replace what:=fnd, Replacement:=rplc, _
    LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
    SearchFormat:=False, ReplaceFormat:=False
Next sht

ActiveSheet.Range("Table1[#All]").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), Header:=xlYes
ThisWorkbook.RefreshAll
End Sub


        Function GetFolder() As String
        Dim oFolder As Object
        GetFolder = ""
        Set oFolder = CreateObject("Shell.Application").Browseforfolder(0, "Choose a folder ", 0) ''
        If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
        Set oFolder = Nothing
        End Function

It reads a xml file and pastes the values in each cell. However, if the form is left blank it does not record the xml name and the results are no longer aligned. the XML file is below:
Code:
<!--?xml version="1.0" encoding="UTF-8"?-->
<xfdf xmlns="http://ns.adobe.com/xfdf/" xml:space="preserve" 
 `?xml version="1.0" encoding="UTF-8"?`
`xfdf xmlns="http://ns.adobe.com/xfdf/" xml:space="preserve"
``fields
``field name="1a"
``value
`Murdy`/value
``/field
``field name="1b"
``value
`William`/value
``/field
``field name="1c"
``value
`D`/value
``/field
``field name="1d"
``value
`E7`/value
``/field
``field name="1e"
``value
`william.murdy@fe.navy.mil`/value
``/field
``field name="1f"
``value
`315.243.8942`/value
``/field
``field name="1g"
``value
`61054`/value
``/field
``field name="1h"
``value
`N00R`/value
``/field
``field name="1i"
``value
`Division`/value
``/field
``field name="1j"
``value
`Off`/value
``/field
``field name="2a"
``value
`Christian`/value
``/field
``field name="3a"
``value
`Off`/value
``/field
``field name="4a"
``value
`Off`/value
``/field
``field name="4b"
``value
`Off`/value
``/field
``field name="5a"
``value
`Off`/value
``/field
``field name="5b"
``value
`Off`/value
``/field
``field name="5c"
``value
`X`/value
``/field
``field name="5d"
``value
`Off`/value
``/field
``field name="5e"
``value
`Off`/value
``/field
``field name="5f"
``field name="a"
``value
`Off`/value
``/field
``/field
``field name="6"
``field name="a"
``value
`Off`/value
``/field
``/field
``field name="7"
``field name="a"
``value
`Off`/value
``/field
``/field
``field name="8a"
``value
`Comment`/value
``/field
``field name="Email"
/``/fields
``ids original="4DB217719D02E13453645B52AEC2B833" modified="B07D15936F96F849BAA2AC2C90F7C2E6"
/``/xfdf
`<ids original="4DB217719D02E13453645B52AEC2B833" modified="B07D15936F96F849BAA2AC2C90F7C2E6" 
<xfdf xmlns="http://ns.adobe.com/xfdf/" xml:space="preserve" 
<ids original="4DB217719D02E13453645B52AEC2B833" modified="B07D15936F96F849BAA2AC2C90F7C2E6" 
 <xfdf xmlns="http://ns.adobe.com/xfdf/" xml:space="preserve" 
<ids original="4DB217719D02E13453645B52AEC2B833" modified="B07D15936F96F849BAA2AC2C90F7C2E6"
The opening and closing tags have been replaced with 'respectively.
How do I assign each field to a column so that the data does not become mismatched? Thank you for your help.</ids></xfdf></ids></xfdf></ids></xfdf>
 
Last edited:

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).
The XML isnt display correctly but its form is
<field name="1a"> <value>
Code:
field name="Last Name"
value
Last Name
/value
/field
</value></field>
 
Last edited:
Upvote 0

Forum statistics

Threads
1,223,885
Messages
6,175,184
Members
452,615
Latest member
bogeys2birdies

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top