Extraer datos específicos de un xml (campos repetidos)
Básicamente es una pregunta similar que ya habían comentado, pero en mi caso quiero extraer información del XML pero el campo de llama igual (importe) y solo me lee el primer campo que encuentra.
Esta es la macro que generaste en el otro ejemplo, nada más faltaría sacar otros campos que te comento están duplicados en nombre.
Te envío unos xml a tu cuenta de correo.
Los campos que necesito son los impuestos retenidos (importes)
ISR sp
ISR142 si es que hubiera este ultimo.
GRACIAS de antemano
Sub Extraccion()
'Por.Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set l1 = ThisWorkbook
Set h1 = l1.Sheets(1)
h1.UsedRange.Offset(1, 0).ClearContents
'
datos = Array("/cfdi:Receptor/@rfc", _
"/cfdi:Receptor/@nombre", _
"/@total", _
"/cfdi:Conceptos/cfdi:Concepto/@descripcion", _
"/@fecha", _
"/cfdi:Complemento/nomina:Nomina/@FechaInicialPago", _
"/cfdi:Complemento/nomina:Nomina/@FechaFinalPago", _
"/cfdi:Complemento/nomina:Nomina/@NumDiasPagados")
ruta = l1.Path & "\"
arch = Dir(ruta & "*.xml")
j = 2
k = 2
Do While arch <> ""
Set l2 = Workbooks.Open(Filename:=ruta & arch)
Set h2 = l2.Sheets(1)
h1.Cells(j, "A") = arch
For i = LBound(datos) To UBound(datos)
Set b = h2.Rows(2).Find(datos(i), lookat:=xlPart)
If Not b Is Nothing Then
h1.Cells(j, k) = h2.Cells(3, b.Column)
k = k + 1
End If
Next
l2.Close
j = j + 1
k = 2
arch = Dir()
Loop
h1.Cells.EntireColumn.AutoFit
MsgBox "Fin"
End Sub
Respuesta de Dante Amor
2
Envíame un correo nuevo, en el asunto del correo pon tu nombre de usuario: "Systemas"
Me envías ejemplos de xml y en un excel me pones los datos que quieres de los xml
¡Gracias! Ok
Te anexo la macro actualizada
Sub Botón1_Haga_clic_en()
'
'Botón1_Haga_clic_en Macro
'Sub Extraccion()
'Por.Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set l1 = ThisWorkbook
Set h1 = l1.Sheets(1)
h1.UsedRange.Offset(1, 0).ClearContents
'
datos = Array("/cfdi:Receptor/@nombre", _
"/cfdi:Receptor/@rfc", _
"Deduccion/@Clave")
'
ruta = l1.Path & "\"
arch = Dir(ruta & "*.xml")
j = 2
Do While arch <> ""
k = 2
Set l2 = Workbooks.Open(Filename:=ruta & arch)
Set h2 = l2.Sheets(1)
h1.Cells(j, "A") = arch
For i = LBound(datos) To UBound(datos)
Set b = h2.Rows(2).Find(datos(i), lookat:=xlPart)
If Not b Is Nothing Then
If i = 2 Then
m = 3
Do While h2.Cells(m, b.Column) <> ""
Select Case h2.Cells(m, b.Column)
Case 52 'imss
h1.Cells(j, "E") = h2.Cells(m, b.Column + 2)
Case 61 'pres fonacot
h1.Cells(j, "F") = h2.Cells(m, b.Column + 2)
Case 49 'isr sp
h1.Cells(j, "D") = h2.Cells(m, b.Column + 2)
End Select
m = m + 1
Loop
Else
h1.Cells(j, k) = h2.Cells(3, b.Column)
k = k + 1
End If
End If
Next
l2.Close
j = j + 1
arch = Dir()
Loop
h1.Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True
MsgBox " Extracción de datos....100% "
End Sub.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
.
Avísame cualquier duda
.
