Modificación de macro para poder elegir xml desde una carpeta
Modificación de macro para poder elegir xml desde una carpeta, y poner en la celda b2 la dirección elegida, donde están los archivos de los que estoy buscando.
Sub ExtraerFolioFiscal2()
'Act.Por.Dante Amor
Dim cp, Archivos
Dim y, Fila, FolioFiscal
Application.ScreenUpdating = False
ActiveSheet.DisplayPageBreaks = False
Fila = Range("A" & Rows.Count).End(xlUp).Row + 1
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Selecciona una carpeta"
.AllowMultiSelect = False
.InitialFileName = ThisWorkbook.Path & "\"
If .Show <> -1 Then Exit Sub
cp = .SelectedItems(1) & "\"
End With
'
[B1] = cp
Archivos = Dir(cp & "*.xml")
Do While Archivos <> ""
Workbooks.OpenXML Filename:=Archivos
1 respuesta
H o l a:
Te anexo la macro para elegir los xml de una carpeta, puedes seleccionar uno o varios presionando la tecla shift o la tecla control.
Sub ExtraerFolioFiscal2()
'Act.Por.Dante Amor
Dim cp, Archivos
Dim y, Fila, FolioFiscal
Application.ScreenUpdating = False
ActiveSheet.DisplayPageBreaks = False
Fila = Range("A" & Rows.Count).End(xlUp).Row + 1
'
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Seleccione archivo de excel"
.Filters.Clear
.Filters.Add "Archivos Xml", "*.xml*"
.AllowMultiSelect = True
.InitialFileName = ThisWorkbook.Path & "\"
If Not .Show Then Exit Sub
ruta = .SelectedItems(1)
diag = InStrRev(ruta, "\")
[B2] = Left(ruta, diag)
For Each ar In .SelectedItems
arch = Mid(ar, diag + 1)
Workbooks.OpenXML Filename:=ar
y = 1: FolioFiscal = ""
Do Until Cells(2, y) = ""
Select Case Trim(Cells(2, y))
Case "/cfdi:Complemento/tfd:TimbreFiscalDigital/@UUID": FolioFiscal = Cells(3, y)
Case "/@serie": SERIE = Cells(3, y)
Case "/@folio": FOLIO = Cells(3, y)
Case "/cfdi:Receptor/@rfc": RECEPTORRFC = Cells(3, y)
Case "/cfdi:Receptor/@nombre": RECEPTORNOMBRE = Cells(3, y)
Case "/cfdi:Emisor/@rfc": EMISORRFC = Cells(3, y)
Case "/cfdi:Emisor/@nombre": EMISORNOMBRE = Cells(3, y)
Case "/@Moneda": MONEDA = Cells(3, y)
Case "/@TipoCambio": TIPOCAMBIO = Cells(3, y)
Case "/@subTotal": Subtotal = Cells(3, y)
Case "/cfdi:Impuestos/@totalImpuestosRetenidos": TOTALIMPUESTOSRETENIDOS = Cells(3, y)
Case "/cfdi:Impuestos/@totalImpuestosTrasladados": TOTALIMPUESTOSTRASLADADOS = Cells(3, y)
Case "/@total": Total = Cells(3, y)
Case "/cfdi:Conceptos/cfdi:Concepto/@descripcion": CONCEPTO = Cells(3, y)
Case "/@fecha": FECHA = Cells(3, y)
Case "/@LugarExpedicion": LugarExpedicion = Cells(3, y)
Case "/@tipoDeComprobante": TIPODECOMPROBANTE = Cells(3, y)
End Select
y = y + 1
Loop
'--
ActiveWorkbook.Close
Range("A" & Fila) = arch
Range("B" & Fila) = FolioFiscal
Range("C" & Fila) = SERIE
Range("D" & Fila) = FOLIO
Range("E" & Fila) = RECEPTORRFC
Range("F" & Fila) = RECEPTORNOMBRE
Range("G" & Fila) = EMISORRFC
Range("H" & Fila) = EMISORNOMBRE
Range("I" & Fila) = MONEDA
Range("J" & Fila) = TIPOCAMBIO
Range("K" & Fila) = Subtotal
Range("L" & Fila) = TOTALIMPUESTOSRETENIDOS
Range("M" & Fila) = TOTALIMPUESTOSTRASLADADOS
Range("N" & Fila) = Total
Range("O" & Fila) = CONCEPTO
Range("P" & Fila) = FECHA
Range("Q" & Fila) = LugarExpedicion
Range("R" & Fila) = TIPODECOMPROBANTE
Fila = Fila + 1
Next
End With
'
Application.ScreenUpdating = True
MsgBox "Fin"
End Sub‘
S a l u d o s . D a n t e A m o r. Recuerda valorar la respuesta. G r a c i a s
¡Gracias! Dante, por el tiempo en contestar la pregunta, tengo una duda en el macro dante, que me ha surgido ya que recuerdas, que me ayudaste en el "case " para no poner el IF y el then pero, cuando extraigo la información hay veces que por ejemplo:¿El iva del primer xml son 60.4 y el que sigue no tiene iva entonces lo copia al siguiente xml como le podría ser para que no me ponga la información del primer archivo abajo? No se si me puedas contestar aquí o tengo que hacer otra pregunta en el foro, de todos modos siempre tus respuestas muy asertivas gracias por ayudarme ala macro saludos.
Tienes que poner antes del Do Until lo siguiente:
FolioFiscal = "" SERIE = "" ... Y así para cada variable
