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