vba - Inserting a Unique ID in Specific Row Locations for Multiple IDs

Question

I have a number of identical XML reports stored in excel. In these reports, each item in one of the tables in each report a unique ID relating that item to a specific entity. Each entity has multiple items associated with it. Essentially, the structure of the macro I am looking for is as follows:

1) Excel searches for the ENTITY title tag in the XML report and stores the value contained between the end of the left tag (i.e. >) and the beginning of the right tag (i.e. <).

2) Excel searches for the ITEM title tag (the match must be exact).

3) Excel selects the row below the ITEM title tag and moves it down, and inserts the stored ENTITY value to the now empty cell above.

4) Excel continues to do this for all instances of the ITEM tag until it reaches another ENTITY title tag, at which point it loops.

I am thinking I would just need two loops, the ENTITY loop taking priority over the ITEM loop so that it is constantly looking for a new ENTITY. Otherwise I have no idea how it will know to start looking for a new entity.

Any help would be appreciated, thanks!

EDIT:

For reference the XML looks like this:

<Results xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xmlns:xsd="http://www.w3.org/2001/XMLSchema">
  <Reference>{REFERENCE-HERE}</Reference>
  <FillerTags>Filler</FillerTags>
  <entity>
    <entityName>ABC</entityName>
    <entityId>012345</entityId>
  </entity>
  <Items>
    <Item>
      <FillerTagsAgain>Filler2</FillerTagsAgain>
      <FillerTagsAgain>Filler2</FillerTagsAgain>
      <FillerTagsAgain>Filler2</FillerTagsAgain> 
     </Item>
     <AnotherItem> 
       <FillerTagsAgain>Filler2</FillerTagsAgain>
       <FillerTagsAgain>Filler2</FillerTagsAgain>
       <FillerTagsAgain>Filler2</FillerTagsAgain> 
     </AnotherItem>
   </Items>

and would be modified to look like this:

<Results xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xmlns:xsd="http://www.w3.org/2001/XMLSchema">
  <Reference>{REFERENCE-HERE}</Reference>
  <FillerTags>Filler</FillerTags>
  <entity>
    <entityName>ABC</entityName>
    <entityId>012345</entityId>
  </entity>
  <Items>
    <Item>
      <entityId>012345</entityId>
      <FillerTagsAgain>Filler2</FillerTagsAgain>
      <FillerTagsAgain>Filler2</FillerTagsAgain>
      <FillerTagsAgain>Filler2</FillerTagsAgain> 
     </Item>
     <AnotherItem> 
       <entityId>012345</entityId>
       <FillerTagsAgain>Filler2</FillerTagsAgain>
       <FillerTagsAgain>Filler2</FillerTagsAgain>
       <FillerTagsAgain>Filler2</FillerTagsAgain> 
     </AnotherItem>
   </Items>
 <entity>
    .
    .
    .

I have tried to start by defining some variables and trying to set up a basic structure:

Dim entity As String
Dim item As String
Dim i As Long
Dim j As Long
Dim wb As Workbook
Dim LastEntity As Long
Dim LastItem As Long

LastEntity = Cells.CountIf(Range("A1:A438486")), "<Entity>")

With ActiveSheet
    For i = 1 To LastEntity
    Cells.Find(What:="ENTITY(i)", After:=ActiveCell, LookIn:=xlFormulas, _
               MatchCase:=False, SearchFormat:=False).Activate
        For j = 1 To LastItem

The first place I am stuck then is as follows: How do I tell VBA to cycle through all the values that come up when using the 'Find' function. For example, if appears 50 times how do I tell VBA to start with the first entity, then begin the For j = 1 To LastItem loop? Is the setup above anywhere close to correct?

Answer 1

Copy your XML in to a plain text file using Notepad/etc. Then save as an XML file making sure that file type is "All files ."

Then close that XML file.

The following example illustrates how to parse and modify the XML per your question. I am not going to show you how to do this using Excel worksheets, that is frankly an objectively wrong way of manipulating XML data.

This code successfully modifies the XML from your initial state to the described example output.

Option Explicit
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub ParseResults()
'Requires reference to Microsoft XML, v6.0
'Requires referenc to Microsoft Scripting Runtime
Dim xmlFilePath$, newFilePath$
Dim DOM As MSXML2.DOMDocument
Dim entity As IXMLDOMNode
Dim fso As Scripting.FileSystemObject

'# Define the file you are going to load as XML
xmlFilePath = "C:usersdavid_zemensdesktop
esults.xml"

'# Define an output path for where to put the modified XML
newFilePath = "C:usersdavid_zemensdesktopupdated_results.xml"

'# Create our DOM object
Set DOM = CreateObject("MSXML2.DOMDocument")

'# Load the XML file
DOM.Load xmlFilePath

'# Wait until the Document has loaded
Do
    Sleep 250
Loop Until DOM.ReadyState = 4

'# Get the entityID node
Set entity = DOM.DocumentElement.getElementsByTagName("entityId")(0)

'# Call a subroutine to append the entity to "Item" tags
AppendEntity DOM, "Item", entity
'# Call a subroutine to append the entity to "AnotherItem" tags
AppendEntity DOM, "AnotherItem", entity

'## Create an FSO to write the new file
Set fso = CreateObject("Scripting.FileSystemObject")

'## Attempt to write the new/modified XML to file
On Error Resume Next
fso.CreateTextFile(newFilePath, True, True).Write DOM.XML
If Err Then
    '## Print the new XML in the Immediate window
    Debug.Print DOM.XML
    MsgBox "Unable to write to " & newFilePath & " please review XML in the Immediate window in VBE.", vbInformation
    Err.Clear
End If
On Error GoTo 0

'Cleanup
Set DOM = Nothing
Set fso = Nothing
Set entity = Nothing

End Sub

Sub AppendEntity(DOM As Object, tagName As String, copyNode As Object)
'## This subroutine will append child node to ALL XML Nodes matching specific string tag.
Dim itemColl As IXMLDOMNodeList
Dim itm As IXMLDOMNode

'# Get a collection of all elements matching the tagName
Set itemColl = DOM.DocumentElement.getElementsByTagName(tagName)

'# Iterate over the collection, appending the copied node
For Each itm In itemColl
    If itm.HasChildNodes Then
        '# Insert this node before the first child node of Item
        itm.InsertBefore copyNode.CloneNode(True), itm.FirstChild
    Else
        '# Append this node to the Item
        itm.appendChild copyNode.CloneNode(True)
    End If
Next

Set itm = Nothing
Set itemColl = Nothing

End Sub

UPDATE

Added a busy/waiting loop to (hopefully) ensure that DOM has fully loaded the XML. On a larger file than the simple example, this may take a few seconds to load, and that could raise errors if you attempt to parse the XML before it's ready.