Firstartemis
New Member
- Joined
- Jun 17, 2015
- Messages
- 10
Good Morning Mr. Excel,
I've written a working xml parser macro that processes an emailed adobe survey. It uses early binding of the MSXML library and seems to work as intended. I guess I'm requesting feedback on if there is a more efficient way to code and I'd like to make sure its compatible with both 32 and 64 bit excel platforms. The original macro pulled all the survey responses, but we found that the adobe survey will not include an xml entry if the answer is blank leaving mismatched entries in the spreadsheet. Our spreadsheet is in Table format to help us create pivot tables and charts from the data.
My main concern is compatibility and efficiency, however, if you know how to integrate Microsoft Outlook into the macro, I'm open to suggestions. The current process is to manually move the attachment from an email and rename it as unique file name. Thank you for your suggestions.
I've written a working xml parser macro that processes an emailed adobe survey. It uses early binding of the MSXML library and seems to work as intended. I guess I'm requesting feedback on if there is a more efficient way to code and I'd like to make sure its compatible with both 32 and 64 bit excel platforms. The original macro pulled all the survey responses, but we found that the adobe survey will not include an xml entry if the answer is blank leaving mismatched entries in the spreadsheet. Our spreadsheet is in Table format to help us create pivot tables and charts from the data.
My main concern is compatibility and efficiency, however, if you know how to integrate Microsoft Outlook into the macro, I'm open to suggestions. The current process is to manually move the attachment from an email and rename it as unique file name. Thank you for your suggestions.
Code:
Sub ProcessRNA()
Dim XDoc As New MSXML2.DOMDocument
Dim xmlNodelist As MSXML2.IXMLDOMNodeList
Dim WkSht As Worksheet, i As Long
Dim strFolder As String, strFile As String
Dim sht As Worksheet
Dim fnd As Variant
Dim rplc As Variant
'Choose folder where .xml files are kept
strFolder = GetFolder
If strFolder = "" Then Exit Sub
Set WkSht = ActiveSheet
'Finds last row
i = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
strFile = Dir(strFolder & "\*.xfdf", vbNormal)
While strFile <> ""
i = i + 1
XDoc.async = False
XDoc.validateOnParse = False
XDoc.Load (strFolder & "\" & strFile)
On Error Resume Next
WkSht.Cells(i, 1) = XDoc.DocumentElement.SelectNodes("fields/field[@name='1a']")(0).Text
WkSht.Cells(i, 2) = XDoc.DocumentElement.SelectNodes("fields/field[@name='1b']")(0).Text
WkSht.Cells(i, 3) = XDoc.DocumentElement.SelectNodes("fields/field[@name='1c']")(0).Text
WkSht.Cells(i, 4) = XDoc.DocumentElement.SelectNodes("fields/field[@name='1d']")(0).Text
WkSht.Cells(i, 5) = XDoc.DocumentElement.SelectNodes("fields/field[@name='1e']")(0).Text
WkSht.Cells(i, 6) = XDoc.DocumentElement.SelectNodes("fields/field[@name='1f']")(0).Text
WkSht.Cells(i, 7) = XDoc.DocumentElement.SelectNodes("fields/field[@name='1g']")(0).Text
WkSht.Cells(i, 8) = XDoc.DocumentElement.SelectNodes("fields/field[@name='1h']")(0).Text
WkSht.Cells(i, 9) = XDoc.DocumentElement.SelectNodes("fields/field[@name='1i']")(0).Text
WkSht.Cells(i, 10) = XDoc.DocumentElement.SelectNodes("fields/field[@name='1j']")(0).Text
WkSht.Cells(i, 11) = XDoc.DocumentElement.SelectNodes("fields/field/field[@name='a']")(0).Text
WkSht.Cells(i, 12) = XDoc.DocumentElement.SelectNodes("fields/field[@name='2b']")(0).Text
WkSht.Cells(i, 13) = XDoc.DocumentElement.SelectNodes("fields/field[@name='3']")(0).Text
WkSht.Cells(i, 14) = XDoc.DocumentElement.SelectNodes("fields/field[@name='4a']")(0).Text
WkSht.Cells(i, 15) = XDoc.DocumentElement.SelectNodes("fields/field[@name='4b']")(0).Text
WkSht.Cells(i, 16) = XDoc.DocumentElement.SelectNodes("fields/field[@name='5a']")(0).Text
WkSht.Cells(i, 17) = XDoc.DocumentElement.SelectNodes("fields/field[@name='5b']")(0).Text
WkSht.Cells(i, 18) = XDoc.DocumentElement.SelectNodes("fields/field[@name='5c']")(0).Text
WkSht.Cells(i, 19) = XDoc.DocumentElement.SelectNodes("fields/field[@name='5d']")(0).Text
WkSht.Cells(i, 20) = XDoc.DocumentElement.SelectNodes("fields/field[@name='5e']")(0).Text
WkSht.Cells(i, 21) = XDoc.DocumentElement.SelectNodes("fields/field[@name='5f']")(0).Text
WkSht.Cells(i, 22) = XDoc.DocumentElement.SelectNodes("fields/field[@name='6']")(0).Text
WkSht.Cells(i, 23) = XDoc.DocumentElement.SelectNodes("fields/field[@name='7']")(0).Text
WkSht.Cells(i, 24) = XDoc.DocumentElement.SelectNodes("fields/field[@name='8a']")(0).Text
strFile = Dir()
Wend
Application.ScreenUpdating = True
'Declutters Excel File
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
'Removes duplicates
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