使用VBA將XML匯入Excel

現在我們正在通過右鍵單擊匯入 XML 檔案（每天更改，每晚最多 5 個），匯入 XML 并匯入我們需要的單個列或資料。我已經撰寫了一些 VBA 代碼來完成我需要做的所有事情，匯入到某個單元格，根據彈出的問題繼續或停止，然后列印輸出。但目前 XML 檔案的匯入匯入了 26 列的資料。我想只隔離條形碼值或一列資料。

這是我目前擁有的代碼：

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

我想我會附上 XML 檔案的開頭部分

<?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>

我需要在列中匯入的資料是條形碼編號EX： 2022000009 或XML檔案中

<SampleBarcode>2022000009</SampleBarcode>

先感謝您！

uj5u.com熱心網友回復：

無需打開每個作業簿即可獲取所需資料。此外，您的代碼可以更有效地重寫。

下面的代碼使用 DOMDocument 物件來加載和決議您的檔案，并且只從 SampleBarcode 元素中檢索文本。

檢查您的參考資料（VBE >> 工具 >> 參考資料）以獲取最新版本的 Microsoft XML 庫。我的最新版本是 Microsoft XML, v6.0，所以我用...

CreateObject("MSXML2.DOMDocument.6.0")

...創建一個 DOMDocument 物件的實體。根據您的版本更改此設定。

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

標籤：擅长 xml vba

上一篇：XSL1.0在每個回圈中選擇真/假值

下一篇：通過Powershell編輯XML節點