Generating XML tags in Excel using Levels column in VBA

[vds1]

Hello Gurus,

Hope your staying safe, posting after long time.

so I have a sheet with table that contains Level, XML tag and Value in Column A, B and C respectively as shown below in Sheet named as "Master"

LEVEL (COLUMN A)	XML TAG (COLUMN B)	VALUE (COLUMN C)
1​	<AppHdr>
2​	<Fr>
3​	<OrgId>
4​	<Id>
5​	<OrgId>
6​	<Othr>
7​	<Id>	50
2​	<To>
3​	<OrgId>
4​	<Id>
5​	<OrgId>
6​	<Othr>
7​	<Id>	60
2​	<BMsgIdr>	MSG1
2​	<MDefIdr>	MSG2

The output will be multi level XML tags in new sheet starting from column A

<AppHdr>
	<Fr>
		<OrgId>
			<Id> 50
				<OrgId>
					<Othr>
						<Id> 50
						</Id>
					</Othr>
				</OrgId>
			</Id>
		</OrgId>
	</Fr>
	<To>
		<OrgId>
				<Id> 51
					<OrgId>
						<Othr>
							<Id> 60
							</Id>
						</Othr>
					</OrgId>
				</Id>
		</OrgId>
	</To>
	<BMsgIdr> MSG1
	</BMsgIdr>
	<MDefIdr> MSG2
	</MDefIdr>
</AppHdr>

Any guidance is much appreciated.. Thank you for looking into it

 

[vds1]

bump

 

[Bo_Ry]

Please create a new Result Sheet and try

Sub XMLtag()
Dim c As Range, r As Long, i As Long, dic As Object
Sheets("Master").Cells.Replace What:=ChrW(8203), Replacement:=""
Set dic = CreateObject("Scripting.Dictionary")
r = 1
With Sheets("Result")
    .UsedRange.Clear
    For Each c In Sheets("Master").Range("A2", Sheets("Master").Range("A2").End(xlDown))
        .Cells(r, c.Value) = c.Offset(, 1) & c.Offset(, 2)
        If dic.Exists(c.Value) Then
            dic(c.Value) = "</" & Mid(c.Offset(, 1), 2, 20)
        Else
            dic.Add c.Value, "</" & Mid(c.Offset(, 1), 2, 20)
        End If
        If c >= c.Offset(1) Then
            For i = c To Application.Max(1, c.Offset(1)) Step -1
                r = r + 1
                .Cells(r, i) = dic(i)
            Next i
        End If
        r = r + 1
    Next c
End With
End Sub

 

[vds1]

Please create a new Result Sheet and try

Sub XMLtag()
Dim c As Range, r As Long, i As Long, dic As Object
Sheets("Master").Cells.Replace What:=ChrW(8203), Replacement:=""
Set dic = CreateObject("Scripting.Dictionary")
r = 1
With Sheets("Result")
    .UsedRange.Clear
    For Each c In Sheets("Master").Range("A2", Sheets("Master").Range("A2").End(xlDown))
        .Cells(r, c.Value) = c.Offset(, 1) & c.Offset(, 2)
        If dic.Exists(c.Value) Then
            dic(c.Value) = "</" & Mid(c.Offset(, 1), 2, 20)
        Else
            dic.Add c.Value, "</" & Mid(c.Offset(, 1), 2, 20)
        End If
        If c >= c.Offset(1) Then
            For i = c To Application.Max(1, c.Offset(1)) Step -1
                r = r + 1
                .Cells(r, i) = dic(i)
            Next i
        End If
        r = r + 1
    Next c
End With
End Sub

YOU ARE A CHAMP! THANK YOU VERY MUCH