XML Import to Excel using VBA

Question

We import an XML file (changes daily, and up to 5 per night) by right clicking, import, XML and it imports the single column or data we need.

I have written VBA code doing everything I need to do, import to a certain cell, continue or stop based on a pop-up question, and a printout later on.
But the import of the XML file imports 26 columns worth of data. I would like to isolate the barcode value or one column's worth of data.

Here is the code I have at the moment:

Option Explicit

Sub Biotinidase_Auto_Import_Print()

 Dim AnswerYes As String
 Dim AnswerNo As String
 Dim strTargetFile As String
 Dim wb As Workbook

'Plate 1
Application.Goto (ActiveWorkbook.Sheets("Panthera File 1").Range("B2"))
    Application.ScreenUpdating = False
     Application.DisplayAlerts = False
     strTargetFile = Application.GetOpenFilename
     Set wb = Workbooks.OpenXML(Filename:=strTargetFile, LoadOption:=xlXmlLoadImportToList)
     Application.DisplayAlerts = True

     wb.Sheets(1).UsedRange.Copy ThisWorkbook.Sheets("Panthera File 1").Range("B2")
     wb.Close False
     Application.ScreenUpdating = True

    
 AnswerYes = MsgBox("Do you want to import more plates?", vbQuestion + vbYesNo, "User Repsonse")

 If AnswerYes = vbYes Then
    'Plate 2
     Application.Goto (ActiveWorkbook.Sheets("Panthera File 2").Range("B2"))
     Application.ScreenUpdating = False
     Application.DisplayAlerts = False
     strTargetFile = Application.GetOpenFilename
     Set wb = Workbooks.OpenXML(Filename:=strTargetFile, LoadOption:=xlXmlLoadImportToList)
     Application.DisplayAlerts = True
     
     wb.Sheets(1).UsedRange.Copy ThisWorkbook.Sheets("Panthera File 2").Range("B2")
     wb.Close False
     Application.ScreenUpdating = True
    
    AnswerYes = MsgBox("Do you want to import more plates?", vbQuestion + vbYesNo, "User Repsonse")
    
        If AnswerYes = vbYes Then
            'Plate 3
            Application.Goto (ActiveWorkbook.Sheets("Panthera File 3").Range("B2"))
            Application.ScreenUpdating = False
            Application.DisplayAlerts = False
            strTargetFile = Application.GetOpenFilename
            Set wb = Workbooks.OpenXML(Filename:=strTargetFile, LoadOption:=xlXmlLoadImportToList)
            Application.DisplayAlerts = True

            wb.Sheets(1).UsedRange.Copy ThisWorkbook.Sheets("Panthera File 3").Range("B2")
            wb.Close False
            Application.ScreenUpdating = True
                
            AnswerYes = MsgBox("Do you want to import more plates?", vbQuestion + vbYesNo, "User Repsonse")
    
            If AnswerYes = vbYes Then
                'Plate 4
                    Application.Goto (ActiveWorkbook.Sheets("Panthera File 4").Range("B2"))
                    Application.ScreenUpdating = False
                    Application.DisplayAlerts = False
                    strTargetFile = Application.GetOpenFilename
                    Set wb = Workbooks.OpenXML(Filename:=strTargetFile, LoadOption:=xlXmlLoadImportToList)
                    Application.DisplayAlerts = True

                    wb.Sheets(1).UsedRange.Copy ThisWorkbook.Sheets("Panthera File 4").Range("B2")
                    wb.Close False
                    Application.ScreenUpdating = True
                    AnswerYes = MsgBox("Do you import more plates?", vbQuestion + vbYesNo, "User Repsonse")
    
                    If AnswerYes = vbYes Then
                        'Plate 5
                        Application.Goto (ActiveWorkbook.Sheets("Panthera File 5").Range("B2"))
                        Application.ScreenUpdating = False
                        Application.DisplayAlerts = False
                        strTargetFile = Application.GetOpenFilename
                        Set wb = Workbooks.OpenXML(Filename:=strTargetFile, LoadOption:=xlXmlLoadImportToList)
                        Application.DisplayAlerts = True

                        wb.Sheets(1).UsedRange.Copy ThisWorkbook.Sheets("Panthera File 5").Range("B2")
                        wb.Close False
                        Application.ScreenUpdating = True
                        ThisWorkbook.PrintOut From:=16, To:=20 'Print Plate Maps 1 - 5
        
                        Else
                            ThisWorkbook.PrintOut From:=16, To:=19 'Print Plate Maps 1 - 4
                        End If
        
                Else
                    ThisWorkbook.PrintOut From:=16, To:=18 'Print Plate Maps 1 - 3
                End If
        
        
        Else
            ThisWorkbook.PrintOut From:=16, To:=17 'Print Plate Maps 1 & 2
        End If
 Else
   
   ThisWorkbook.PrintOut From:=16, To:=16 'Print Plate Map 1
   
 End If

End Sub

The beginning part of the XML file

<?xml version="1.0" encoding="utf-8"?>
<Plate xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xmlns:xsd="http://www.w3.org/2001/XMLSchema">
  <AnalyteName>BT</AnalyteName>
  <TraversalOrder>
    <OrderIndex>Rows</OrderIndex>
  </TraversalOrder>
  <PlateMapName>BT:1</PlateMapName>
  <Barcode>
    <Orientation>Vertical</Orientation>
    <Code>BT00001</Code>
    <CodeType>Code128</CodeType>
    <ErrorDescription />
  </Barcode>
  <PlateTypeName>ThermoCliniplate</PlateTypeName>
  <Wells>
    <Well>
      <Index>0</Index>
      <SampleBarcode>2022000009</SampleBarcode>
      <WellType>
        <Type>Patient</Type>
        <Level>0</Level>
      </WellType>
      <IsBad>false</IsBad>
      <RequestedDisksPerWell>1</RequestedDisksPerWell>
      <PunchedDisksPerWell>1</PunchedDisksPerWell>
    </Well>
    <Well>
      <Index>1</Index>
      <SampleBarcode>2022000000</SampleBarcode>
      <WellType>
        <Type>Patient</Type>
        <Level>0</Level>
      </WellType>
      <IsBad>false</IsBad>
      <RequestedDisksPerWell>1</RequestedDisksPerWell>
      <PunchedDisksPerWell>1</PunchedDisksPerWell>
    </Well>

The data I need to import in the column is the barcode number
EX: 2022000009
or in the XML file

<SampleBarcode>2022000009</SampleBarcode>

And your question is? Please be explicit. Are you after the just the barcode value? Can your code be reduced to just the lines necessary to demonstrate what you have tried? See How to Ask — QHarr
– QHarr, Commented Jun 8, 2022 at 11:00
Yes, I am after the barcode value. Right now the script will import 26 columns worth of data into the worksheet, but I only need one column or value to be imported starting at cell B2. At the moment the only thing I have tried changing was the line Set wb = Workbooks.OpenXML(Filename:=strTargetFile, LoadOption:=xlXmlLoadImportToList) by changing the load option to popup with the XML Schema menu when importing, but this would be to complicated for my coworkers. — Brady Steeples
– Brady Steeples, Commented Jun 8, 2022 at 12:15

score 1 · Accepted Answer · 2022-06-08 19:30:33Z

There's no need to open each of your workbooks to get the data you want. Also, your code can be re-written more efficiently.

The following code uses the DOMDocument object to load and parse your documents, and only retrieves the text from the SampleBarcode element.

Check your references (VBE >> Tools >> References) for your latest version of the Microsoft XML library. My latest version is Microsoft XML, v6.0, so I used...

CreateObject("MSXML2.DOMDocument.6.0")

...to create an instance of the DOMDocument object. Change this according to your version.

Option Explicit

Sub Biotinidase_Auto_Import_Print()

    'Create an instance of the DOMDocument object
    On Error Resume Next
    Dim xmlDoc As Object 'MSXML2.DOMDocument60
    Set xmlDoc = CreateObject("MSXML2.DOMDocument.6.0") 'change the version accordingly
    If xmlDoc Is Nothing Then
        MsgBox "Unable to create an instance of 'DOMDocument.6.0'", vbCritical, "Error"
        Exit Sub
    End If
    On Error GoTo 0
    
    'Wait for the document to load completely
    xmlDoc.async = False
    
    'Create an instance of a Collection to store worksheets to be printed
    Dim worksheetCollection As Collection
    Set worksheetCollection = New Collection
    
    Dim worksheetNames As Variant
    worksheetNames = Array("Panthera File 1", "Panthera File 2", "Panthera File 3", "Panthera File 4", "Panthera File 5")
    
    Dim i As Long
    Dim targetFile As Variant
    Dim destinationWorksheet As Worksheet
    Dim xmlNodes As Object 'MSXML2.IXMLDOMNodeList
    Dim xmlNode As Object 'MSXML2.IXMLDOMNode
    Dim rowIndex As Long
    Dim ans As VbMsgBoxResult
    Dim xmlPE As Object 'MSXML2.IXMLDOMParseError
    Dim abort As Boolean
    abort = False
    For i = LBound(worksheetNames) To UBound(worksheetNames)
        
        'Prompt the user to select an XML file
        targetFile = Application.GetOpenFilename(FileFilter:="XML Data (*.xml), *.xml", Title:="Select XML file")
        
        If targetFile = False Then Exit For
        
        'Load the XML document
        If xmlDoc.Load(targetFile) Then
        
            Set destinationWorksheet = ThisWorkbook.Worksheets(worksheetNames(i))
            
            'Clear any existing data
            With destinationWorksheet
                .Range("B2", .Cells(.Rows.Count, "B").End(xlUp)).ClearContents
            End With
        
            Set xmlNodes = xmlDoc.DocumentElement.SelectNodes("//Plate/Wells/Well/SampleBarcode")

            rowIndex = 2
            For Each xmlNode In xmlNodes
                'Debug.Print xmlNode.Text
                destinationWorksheet.Range("B" & rowIndex).Value = xmlNode.Text
                rowIndex = rowIndex + 1
            Next xmlNode
            
            worksheetCollection.Add destinationWorksheet
            
            ans = MsgBox("Do you want to import more plates?", vbQuestion + vbYesNo, "User Repsonse")
            
            If ans = vbNo Then Exit For
                
        Else
        
            'Document failed to load
            Set xmlPE = xmlDoc.parseError
            
            With xmlPE
                MsgBox "Error " & .ErrorCode & ":  " & .reason, vbCritical, "Error"
                abort = True
                Exit For
            End With
            
        End If
        
    Next i
    
    If Not abort Then
        'Print worksheets, if any
        If worksheetCollection.Count > 0 Then
            Dim ws As Worksheet
            For Each ws In worksheetCollection
                'Debug.Print ws.Name
                ws.PrintOut
            Next ws
        End If
    End If
    
    Set xmlDoc = Nothing
    Set xmlNodes = Nothing
    Set xmlNode = Nothing
    Set xmlPE = Nothing
    
End Sub

This looks amazing thank you! I'm no where near proficient in VBA but cobbled together what I could remember from college. The only thing I might have to change is the printout at the end. There is different sheets that read the data that's imported formats it into a plate map, then prints out the plate map. But that's an easy fix! The only reason I had it going to each workbook is because there is a column next to the imported one that checks for specimens out of order, but that was going to be a different automation step for another day 😅 Thank you!

Collectives™ on Stack Overflow

XML Import to Excel using VBA

1 Answer 1

1 Comment

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

1 Comment

Your Answer

Sign up or log in

Post as a guest

Related