excel macro to import nested xml elements

Question

excel macro to import nested xml elements

Anonymous

I posted a question in the excel forum but it was suggested i post it here.

http://answers.microsoft.com/en-us/office/forum/office\_2010-excel/import-xml-creating-multiple-records-for-each/0c514f61-16ca-4d58-ab72-35b03867e3bf

I have an xml file which has one element, <images> which contains multiple <image> elements.

The <images> element is part of a single record. however when i try to import this xml file into excel 2010, it creates a duplicate record for every <image> in a record.

So for example if i have:

item #123 and it has 3 images, my excel file will look like:

Item# img

123 imgA.jpg

123 imgB.jpg

123 imgC.jpg

What I want my excel file to look like is:

item# img1 img2 img3

123 imgA imgB imgC

I want excel to add as many img columns as needed so that each record appears on one line with enough img columns to support whatever the max # of images there are for a record.

Can this be done? If it makes any difference, I can upgrade to excel 2013

Locked Question. This question was migrated from the Microsoft Support Community. You can vote on whether it's helpful, but you can't add comments or replies or follow the question.

0 comments

1 answer

Answer 1

So for example if i have:

item #123 and it has 3 images, my excel file will look like:

Item# img

123 imgA.jpg

123 imgB.jpg

123 imgC.jpg

What I want my excel file to look like is:

item# img1 img2 img3

123 imgA imgB imgC

That is an usual transform algorithm, there are 2 ways.

At first copy the code below into a regular module in your file.

For this example I assume that your data is in A1:B4

a) Use an UDF and call it with an array formula. The benefit is that the result updates automatically whenever your data changes. The disadvantage is that the array formula must include as many cells as data is available, means it is possible that some data is missing.

Use this formula at min. in D1:G2

{=MatrixOutsideIn(A1:B4,"")}

If you don't know how to enter an array formula, have a look here:

http://www.dummies.com/how-to/content/how-to-build-an-array-formula-in-excel-2010.html

b) Call a macro.

The macro Test below is designed for your data, press Alt-F8 and execute Test.

Andreas.

Option Explicit

Sub Test()

Dim R As Range

Dim Data

'Get all data connected with A1

Set R = Range("A1").CurrentRegion

'Transform it

Data = MatrixOutsideIn(R)

'Find an empty cell below

Set R = R(1, 1).End(xlDown).Offset(2)

'Paste the data

R.Resize(UBound(Data) + 1, UBound(Data, 2) + 1) = Data

End Sub

Function MatrixOutsideIn(Bereich As Range, _

Optional ClearUnusedSpaceValue) As Variant

'Macht aus:

' Kasse A Bier 123,50 €

' Kasse B Bier 176,40 €

' Kasse C Bier 78,50 €

' Kasse D Bier 161,00 €

' Kasse A Wein 98,00 €

' Kasse B Wein 12,50 €

' Kasse C Wein 61,00 €

' Kasse D Wein 23,00 €

' Kasse A Saft 9,20 €

' Kasse B Saft 5,00 €

' Kasse C Saft 14,00 €

' Kasse D Saft 7,80 €

'dies:

' Bier Wein Saft

' Kasse A 123,50 € 98,00 € 9,20 €

' Kasse B 176,40 € 12,50 € 5,00 €

' Kasse C 78,50 € 61,00 € 14,00 €

' Kasse D 161,00 € 23,00 € 7,80 €

'Oder aus:

' StudyNumber SLT

' 10012 Cb

' 10012 MMc

' 10012 Cb

' 11050 Jl

' 11050 Ch

'dies:

' StudyNumber SLT1 SLT2 SLT3 SLT4

' 10012 Cb MMc Cb Cb

' 11050 Jl Jl Ch

Dim Arr(), Data, Items, Keys

Dim DictX As Object, DictY As Object

Dim X As Integer, Y As Long, i As Long, j As Long

If IsMissing(ClearUnusedSpaceValue) Then _

ClearUnusedSpaceValue = CVErr(xlErrNA)

Data = Bereich

Select Case UBound(Data, 2)

Case Is < 2

Exit Function

Case 2

Set DictY = CreateObject("Scripting.Dictionary")

X = 1

'Spalten und Zeilen ermitteln

For i = 2 To UBound(Data)

'Zeile schon vorhanden?

If Not DictY.Exists(Data(i, 1)) Then

'Nein, aufnehmen

Set DictX = New Collection

DictX.Add Data(i, 2)

DictY.Add Data(i, 1), DictX

Else

'Element hinzufügen

Set DictX = DictY.Item(Data(i, 1))

DictX.Add Data(i, 2)

If DictX.Count > X Then X = DictX.Count

End If

Y = DictY.Count

If TypeOf Application.Caller Is Range Then

'Ist der Eingabebereich größer als der Datenbereich?

With Application.Caller

If Y < .Rows.Count Then Y = .Rows.Count - 1

If X < .Columns.Count Then X = .Columns.Count - 1

End With

End If

'Ergebnis dimensionieren

ReDim Arr(0 To Y, 0 To X)

'Überschriften eintragen

Arr(0, 0) = Data(1, 1)

For X = 1 To UBound(Arr, 2)

Arr(0, X) = Data(1, 2) & X

Items = DictY.Items

Keys = DictY.Keys

For Y = 1 To DictY.Count

'Elemente holen

Set DictX = Items(Y - 1)

'Name eintragen

Arr(Y, 0) = Keys(Y - 1)

'Elemente eintragen

For X = 1 To DictX.Count

Arr(Y, X) = DictX.Item(X)

For X = X To UBound(Arr, 2)

Arr(Y, X) = ClearUnusedSpaceValue

If TypeOf Application.Caller Is Range Then

'Unbenutzte Zeilen löschen

For Y = Y To UBound(Arr)

For X = LBound(Arr, 2) To UBound(Arr, 2)

Arr(Y, X) = ClearUnusedSpaceValue

End If

Case Is > 2

Set DictX = CreateObject("Scripting.Dictionary")

Set DictY = CreateObject("Scripting.Dictionary")

'Spalten und Zeilen ermitteln

For i = 1 To UBound(Data)

'Spalte schon vorhanden?

If Not DictX.Exists(Data(i, 2)) Then

'Nein, Index merken

X = X + 1

DictX.Add Data(i, 2), X

End If

'Zeile schon vorhanden?

If Not DictY.Exists(Data(i, 1)) Then

'Nein, Index merken

Y = Y + 1

DictY.Add Data(i, 1), Y

End If

'Ist der Eingabebereich größer als der Datenbereich?

With Application.Caller

If Y < .Rows.Count Then Y = .Rows.Count - 1

If X < .Columns.Count Then X = .Columns.Count - 1

End With

End If

'Ergebnis dimensionieren

ReDim Arr(0 To Y, 0 To X)

If TypeOf Application.Caller Is Range Then

'Unbenutzte Bereiche löschen

With Application.Caller

If DictX.Count < .Columns.Count - 1 Then

'Unbenutzte Spaltenenden löschen

For Y = 0 To .Rows.Count - 1

For X = DictX.Count To .Columns.Count - 1

Arr(Y, X) = ClearUnusedSpaceValue

End If

If DictY.Count < .Rows.Count - 1 Then

'Unbenutzte Zeilenenden löschen

For X = 0 To .Columns.Count - 1

For Y = DictY.Count To .Rows.Count - 1

Arr(Y, X) = ClearUnusedSpaceValue

End If

End With

End If

'Links oben ist immer leer

Arr(0, 0) = ClearUnusedSpaceValue

'Datenfelder eintragen

For i = 1 To UBound(Data)

Y = DictY.Item(Data(i, 1))

X = DictX.Item(Data(i, 2))

Arr(Y, X) = Data(i, 3)

Data = DictX.Keys

For i = 0 To DictX.Count - 1

Arr(0, i + 1) = Data(i)

Data = DictY.Keys

For i = 0 To DictY.Count - 1

Arr(i + 1, 0) = Data(i)

MatrixOutsideIn = Arr

End Function

Share via

excel macro to import nested xml elements

1 answer