Importar un numero de 37 caracteres como texto desde un archivo .xml a Excel mediante una macro.
Cordiales a todos.
Deseo importar varios archivos .xml a una hoja de excel mediante una macro, este es el código.
Sub Extraerdatos()
Dim MiPc, Carpeta, Archivos, Archivo
Dim Fila
Fila = Range("A" & Rows.Count).End(xlUp).Row + 1
Set MiPc = CreateObject("Scripting.FileSystemObject")
Set Carpeta = MiPc.GetFolder(Range("B1").Value)
Set Archivos = Carpeta.Files
For Each Archivo In Archivos
If LCase(Right(Archivo.Name, 4)) = ".xml" Then
Workbooks.OpenXML Filename:=Archivo
fecha = Left(Cells(3, 4), 10)
nAutorizacion = Cells(3, 6) 'ESTE ES EL DATO QUE SE IMPORTA INCOMPLETO
Archivo = ActiveWorkbook.Name
ActiveWorkbook.Close
Range("A" & Fila) = Archivo
Range("B" & Fila) = fecha
Range("C" & Fila) = "" & nAutorizacion
End If
Archivo = "": fecha = "": nAutorizacion = ""
Fila = Fila + 1
Next
End SubEl problema surge al momento de importar un numero de 37 dígitos que por defecto lo transforma a u numero científico y se pierden muchos caracteres de este dato. (Lo marcado en rojo es como necesito importarlo)
<?xml version="1.0" encoding="UTF-8" standalone="yes"?> <autorizacion> <estado>AUTORIZADO</estado> <numeroAutorizacion>0104201616390809908583220015763237938</numeroAutorizacion> <fechaAutorizacion>2016-04-01T16:39:08-05:00</fechaAutorizacion> <ambiente>PRODUCCIÓN</ambiente> <comprobante>E</comprobante> <mensajes/> </autorizacion>
1 Respuesta
Respuesta de Dante Amor
1
Prueba con lo siguiente:
Sub Extraerdatos()
'Act.Por.Dante Amor
Dim MiPc, Carpeta, Archivos, Archivo
Dim Fila
'
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set MiPc = CreateObject("Scripting.FileSystemObject")
Set Carpeta = MiPc.GetFolder(Range("B1").Value)
Set Archivos = Carpeta.Files
For Each Archivo In Archivos
If LCase(Right(Archivo.Name, 4)) = ".xml" Then
Workbooks.OpenXML Filename:=Archivo, LoadOption:=xlXmlLoadImportToList
fecha = Left(Cells(1, 3), 10)
nAutorizacion = Cells(1, 2)
ActiveWorkbook.Close
Fila = Range("A" & Rows.Count).End(xlUp).Row + 1
Range("A" & Fila) = Mid(Archivo, InStrRev(Archivo, "\") + 1)
Range("B" & Fila) = fecha
Range("C" & Fila) = "'" & nAutorizacion
End If
Next
Application.ScreenUpdating = True
MsgBox "Fin"
End Sub
¡Gracias! Se soluciono el problema!!!!!!!!! esto era lo que necesitaba.
Application.DisplayAlerts = False Application.ScreenUpdating = False
