XML Import to Excel using VBA-CodePudding

Right now we are currently importing 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 some 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 currently the import of the XML file imports 26 columns worth of data. I would like to isolate just the barcode value or one columns 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

And I figured I would attach 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>

Thank You in advance!

CodePudding user response：

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