VBA提取CTe XML中nCT标签数据至Excel失败，请求代码修正

问题说明 #

需要从带命名空间的CTe XML文件中提取<nCT>、<serie>以及infCte节点的Id属性值到Excel，原VBA代码在无命名空间的XML中可正常运行，但处理该CTe XML时触发**“对象变量或With块变量未定义”**错误。

给定的CTe XML关键结构：

<cteProc xmlns="http://www.portalfiscal.inf.br/cte" versao="4.00" ipTransmissor="54.233.101.205" nPortaCon="26851" dhConexao="2025-03-14T19:57:55-03:00">
  <CTe xmlns="http://www.portalfiscal.inf.br/cte">
    <infCte versao="4.00" Id="CTe13250347705660000565570020000617541000617540">
      <ide>
        <serie>2</serie>
        <nCT>61754</nCT>
        <!-- 其他节点 -->
      </ide>
    </infCte>
  </CTe>
</cteProc>

原代码错误核心原因：

• 未处理XML命名空间，XPath查询//nCT、//serie无法匹配带命名空间的节点，返回Nothing，访问.Text时触发空对象错误
• 原代码中//infDoc、infNFe/chave节点在当前CTe XML结构中不存在，属于无效查询

优化后的VBA代码 #

Sub ExtrairCTeXML()
    Dim arquivo, arquivos
    Dim xmlDoc As New DOMDocument60
    Dim infCteNode As IXMLDOMNode
    Dim ideNode As IXMLDOMNode
    
    Dim dicionario As New Dictionary
    Dim Id As String, nCT As String, serie As String
    
    ' 选择多个XML文件，用户取消则退出
    arquivos = Application.GetOpenFilename("Arquivos XML(*.xml),*.xml", , "Selecionar os arquivos XML", , True)
    If TypeName(arquivos) = "Boolean" Then Exit Sub
    
    ' 配置XML命名空间与查询语言
    xmlDoc.SetProperty "SelectionNamespaces", "xmlns:cte='http://www.portalfiscal.inf.br/cte'"
    xmlDoc.SetProperty "SelectionLanguage", "XPath"
    xmlDoc.async = False ' 同步加载确保文件读取完成
    
    For Each arquivo In arquivos
        ' 加载XML并检查是否成功
        If Not xmlDoc.Load(arquivo) Then
            MsgBox "Falha ao carregar arquivo: " & arquivo & vbCrLf & xmlDoc.parseError.reason
            GoTo ProximoArquivo
        End If
        
        ' 获取infCte节点及Id属性
        Set infCteNode = xmlDoc.SelectSingleNode("//cte:infCte")
        If infCteNode Is Nothing Then
            MsgBox "Nó infCte não encontrado em: " & arquivo
            GoTo ProximoArquivo
        End If
        Id = infCteNode.Attributes.getNamedItem("Id").Text
        
        ' 获取ide节点下的serie和nCT
        Set ideNode = infCteNode.SelectSingleNode("cte:ide")
        If ideNode Is Nothing Then
            MsgBox "Nó ide não encontrado em: " & arquivo
            GoTo ProximoArquivo
        End If
        nCT = ideNode.SelectSingleNode("cte:nCT").Text
        serie = ideNode.SelectSingleNode("cte:serie").Text
        
        ' 存入字典
        dicionario(dicionario.Count + 1) = Array(Id, nCT, serie)
        
ProximoArquivo:
        ' 重置节点引用
        Set infCteNode = Nothing
        Set ideNode = Nothing
    Next arquivo
    
    ' 写入Excel
    With Planilha1
        .Range("A1:C1").Value = Array("Id", "nCT", "serie")
        If dicionario.Count > 0 Then
            .Range("A2").Resize(dicionario.Count, 3).Value = Application.Transpose(Application.Transpose(dicionario.Items))
        End If
    End With
    
    MsgBox "Extração concluída!", vbInformation
End Sub

关键修改说明 #

1. 命名空间处理：通过SetProperty注册CTe命名空间前缀cte，XPath查询时必须带前缀才能匹配目标节点
2. 错误防护：添加XML加载失败、节点不存在的判断，避免空对象访问触发运行时错误
3. 路径修正：根据CTe XML实际结构调整查询路径，移除原代码中不存在的无效节点查询
4. 健壮性优化：设置同步加载确保XML文件完全读取后再执行查询，避免异步加载导致的节点缺失
5. 输出适配：根据实际提取的3个字段调整Excel输出列数，避免原代码中列数不匹配的问题

内容的提问来源于stack exchange，提问作者Raí Rodrigues