Copy line data from xml file path based on column data in active sheet

[TD9010]

Good Morning,

im trying to copy data from an xml file to an active sheet... i will try to explain it logically.

Table of Data

A b c

Xml File location	String to Search	Resulting Data
C:\temp\Test01.xml	St001
C:\temp\Test01.xml	St002
C:\temp\Test02.xml	St001

<tbody>
</tbody>

I want to search each file that is defined in column A for the String that is defined in column B and then when it finds the string paste the line of data from the .xml into column C.

Example -

1. Search (A1)C:\temp\Test01.xml for (A)St001
2. Identify what line number St001 is on
3. Copy that line of data to cell C1

then move on to the next row until there is a blank cell and stop..

Can any one Help?

Cheers Tom.

 

[Worf]

Good evening Tom

Sub XML_files()
Dim i%, nw As Workbook, r As Range, sh As Worksheet, v%
Set sh = ActiveWorkbook.Sheets("cases")                 ' where destination table is
For i = 2 To sh.Range("b" & Rows.Count).End(xlUp).Row
    Set nw = Workbooks.OpenXML(sh.Cells(i, 1), , xlXmlLoadImportToList) ' open as table
    Set r = nw.ActiveSheet.Cells.Find(sh.Cells(i, 2), LookIn:=xlValues) ' find string
    v = nw.ActiveSheet.ListObjects(1).DataBodyRange.Columns.Count
    Set r = nw.ActiveSheet.Range(Cells(r.Row, 1), Cells(r.Row, v))
    r.Copy sh.Cells(i, 3).Resize(1, v)                                  ' copy row
    nw.Close 0
Next
End Sub

 

[TD9010]

Good evening Tom

Sub XML_files()
Dim i%, nw As Workbook, r As Range, sh As Worksheet, v%
Set sh = ActiveWorkbook.Sheets("cases")                 ' where destination table is
For i = 2 To sh.Range("b" & Rows.Count).End(xlUp).Row
    Set nw = Workbooks.OpenXML(sh.Cells(i, 1), , xlXmlLoadImportToList) ' open as table
    Set r = nw.ActiveSheet.Cells.Find(sh.Cells(i, 2), LookIn:=xlValues) ' find string
    v = nw.ActiveSheet.ListObjects(1).DataBodyRange.Columns.Count
    Set r = nw.ActiveSheet.Range(Cells(r.Row, 1), Cells(r.Row, v))
    r.Copy sh.Cells(i, 3).Resize(1, v)                                  ' copy row
    nw.Close 0
Next
End Sub

worked great thank you.

 

[Worf]

You are welcome and thanks for the feedback.