Macro leer solo conceptos XMl CFDI 3.3

[ErnestoZamora]

Buenas tardes tegno una macro que descargue en este mismo foto la cual lee los XML pero requiero que los conceptos y sus montos los coloque por filas y no las agrupe en una sola columna

 

 

Sub Ruta_CFDI()
Dim fs, carpeta, archivo, subcarpeta As Object
contador = 2
Set fs = CreateObject("Scripting.FileSystemObject")
    
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then
Ruta = .SelectedItems(1)
End If
End With
      
If Ruta = "" Then
 Exit Sub
End If
     
Set carpeta = fs.GetFolder(Ruta)
     
For Each archivo In carpeta.Files
 If Right(archivo, 4) = ".xml" Then
  Range("AB" & contador).value = Ruta & "\" & archivo.Name
  contador = contador + 1
 End If
  If Right(archivo, 4) = ".XML" Then
  Range("AB" & contador).value = Ruta & "\" & archivo.Name
  contador = contador + 1
 End If
Next
     
If contador = 1 Then
MsgBox "No se encontro ningún archivo *.XML" & Chr(10) & Ruta, vbCritical, "Importar datos CFDI"
End If
Call Lectura_CFDI
End Sub

Sub Lectura_CFDI()
Dim doc As MSXML2.DOMDocument60
Dim objXMLDOMNodeList As MSXML2.IXMLDOMNodeList
Dim intIndiceNodo As Integer
Dim Concepto As String

Set doc = New MSXML2.DOMDocument60
Set r = Range("p1").CurrentRegion
filas = r.Rows.Count
 
For i = 2 To filas
    
    doc.Load ("" & Cells(i, 28) & "")
    
    
    Cells(i, 8) = 0
    Cells(i, 9) = 0
    Cells(i, 10) = 0
     
    
    Set lists = doc.DocumentElement

    
    EmisorRFC = lists.ChildNodes(Emisor).getAttribute("Rfc") & lists.ChildNodes(Emisor).getAttribute("rfc")
    EmisorNobmre = lists.ChildNodes(Emisor).getAttribute("nombre") & lists.ChildNodes(Emisor).getAttribute("Nombre")
    EmisorRegimen = lists.ChildNodes(Emisor).getAttribute("RegimenFiscal")
    ReceptorRFC = lists.ChildNodes(1).getAttribute("rfc") & lists.ChildNodes(1).getAttribute("Rfc")
    ReceptorNobmre = lists.ChildNodes(1).getAttribute("nombre") & lists.ChildNodes(1).getAttribute("Nombre")
    ReceptorUso = lists.ChildNodes(1).getAttribute("UsoCFDI")
    

    Set objXMLDOMNodeList = lists.ChildNodes

        For intIndiceAtributo = 0 To objXMLDOMNodeList.Item(2).ChildNodes.Length - 1
        Concepto = Concepto & lists.ChildNodes(2).ChildNodes(intIndiceAtributo).getAttribute("descripcion") & "\" & lists.ChildNodes(2).ChildNodes(intIndiceAtributo).getAttribute("Descripcion") & "\"
        Next intIndiceAtributo
        
       

     

    Cells(i, 2) = doc.DocumentElement.getAttribute("serie") & doc.DocumentElement.getAttribute("Serie")
    Cells(i, 3) = doc.DocumentElement.getAttribute("Folio") & doc.DocumentElement.getAttribute("folio")
    Cells(i, 4) = ReceptorRFC
    Cells(i, 5) = ReceptorNobmre
    Cells(i, 6) = EmisorRFC
    Cells(i, 7) = EmisorNobmre
    Cells(i, 8) = Folio
    Cells(i, 9) = Concepto
    Cells(i, 10) = doc.DocumentElement.getAttribute("subTotal") & doc.DocumentElement.getAttribute("SubTotal")
    
    Cells(i, 14) = doc.DocumentElement.getAttribute("total") & doc.DocumentElement.getAttribute("Total")
    Cells(i, 15) = doc.DocumentElement.getAttribute("fecha") & doc.DocumentElement.getAttribute("Fecha")
    Cells(i, 16) = doc.DocumentElement.getAttribute("fecha") & doc.DocumentElement.getAttribute("FechaTimbrado")
    Cells(i, 17) = doc.DocumentElement.getAttribute("tipoDeComprobante") & doc.DocumentElement.getAttribute("TipoDeComprobante")
    Cells(i, 18) = doc.DocumentElement.getAttribute("CondicionesDePago") & doc.DocumentElement.getAttribute("CondicionesDePago")
    Cells(i, 19) = doc.DocumentElement.getAttribute("FormaPago")
    Cells(i, 20) = doc.DocumentElement.getAttribute("metodoDePago") & doc.DocumentElement.getAttribute("MetodoPago")
    Cells(i, 21) = EmisorRegimen
    Cells(i, 22) = ReceptorUso
    Cells(i, 23) = doc.DocumentElement.getAttribute("Moneda")
    Cells(i, 24) = doc.DocumentElement.getAttribute("LugarExpedicion")
    Cells(i, 25) = doc.DocumentElement.getAttribute("NoCertificado") & doc.DocumentElement.getAttribute("noCertificado")
    Cells(i, 26) = doc.DocumentElement.getAttribute("version") & doc.DocumentElement.getAttribute("Version")
    Cells(i, 27) = RfcProvCertif
    
    

    ReceptorRFC = ""
    ReceptorNobmre = ""
    EmisorRFC = ""
    EmisorNobmre = ""
    Folio = ""
    Concepto = ""
    If Cells(i, 11) = "" Then
    Cells(i, 11) = 0
    End If
    If Cells(i, 12) = "" Then
    Cells(i, 12) = 0
    End If
Next
Set doc = Nothing
MsgBox "Ernesto Zamora" & Chr(10) & "", vbApplicationModal, "Proceso Terminado - Contacto"
End Sub