Traer Datos de un Archivo RDF a Hoja Excel con macros
Para: Dante Amor
Ante Todo un Cordial Saludo, mi consulta es tengo dos botones Activex en mi hoja de excel los cuales seria para que me traigan los datos de archivos con formato RDF a la hoja REGISTROS, según la fecha que se ponga en la celda L5 todos los archivos RDF a buscar se encuentran en la unidad D:\TODO SOBRE MACROS\TEMPERATURAS .
Los botones Anterior y Siguiente son para que puedan mostrar todos los archivos Rdf, ya que hay varios archivos con la misma fecha.
Todo este proceso lo estoy realizando manualmente, lo cual me quita mucho tiempo; bueno solo espero que mi pregunta se haya entendido y mas que todo agradecer por la gran ayuda que me pueda brindar.
1 Respuesta
H o l a:
No conozco los archivos RDF, puedes enviarme un par de archivos RDF y me envías tu archivo de excel.
En el archivo de excel con algún color y con comentarios me explicas cómo cargaste los 2 archivos RDF que me estás enviando.
Mi correo [email protected]
En el asunto del correo escribe tu nombre de usuario “Edgar Castillo” y el título de esta pregunta.
Gracias por la ayuda que me estas brindando.
Estos son los pasos que realizo en la hoja excel para extraer los datos de los archivos DRF, aparte indicarte que ya te lo e enviado los archivos.
El ultimo paso que seria el paso 6 simplemente es aceptar e indicar a partir de que celda es donde saldrá los datos, en este caso escojo la celda A1.
H o l a: Te anexo las macros
Private Sub CommandButton1_Click()
'Por.Dante Amor
'Siguiente
Application.ScreenUpdating = False
Set h1 = Sheets("REGISTROS")
Set h2 = Sheets("conexion")
Set h3 = Sheets("archivos")
For i = 1 To h3.Range("A" & Rows.Count).End(xlUp).Row
If h3.Cells(i, "B") = "x" Then
h3.Cells(i, "B") = ""
h2.Cells.Delete
If h3.Cells(i + 1, "A") <> "" Then
h3.Cells(i + 1, "B") = "x"
Call AbrirArchivo(h2, h3.Cells(i + 1, "A"))
Else
h3.Cells(1, "B") = "x"
Call AbrirArchivo(h2, h3.Cells(1, "A"))
End If
h2.Columns("A:J").Copy
h1.[A1].PasteSpecial xlValue
Exit For
End If
Next
End Sub
'
Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("L5")) Is Nothing Then
Application.ScreenUpdating = False
Set h1 = Sheets("REGISTROS")
Set h2 = Sheets("conexion")
Set h3 = Sheets("archivos")
h3.Cells.Clear
fila = 1
ruta = ThisWorkbook.Path & "\"
arch = Dir(ruta & "*.rdf")
Do While arch <> ""
h2.Cells.Delete
Call AbrirArchivo(h2, ruta & arch)
fecha = CDate(Format(h2.[A3], "dd/mm/yyyy"))
If h1.[L5] = fecha Then
h3.Cells(fila, "A") = ruta & arch
fila = fila + 1
End If
arch = Dir()
Loop
If fila = 1 Then
MsgBox "No hay archivos con la fecha indicada"
Else
h2.Cells.Delete
Call AbrirArchivo(h2, h3.[A1])
h2.Columns("A:J").Copy
h1.[A1].PasteSpecial xlValue
h3.[B1] = "x"
End If
End If
End Sub
'
Sub AbrirArchivo(h2, arch)
'Por.Dante Amor
With h2.QueryTables.Add(Connection:= _
"TEXT;" & arch, Destination:=h2.Range("$A$1"))
.Name = "96645_4095"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End Sub
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
Ante todo gracias por la pronta respuesta e indicarte que la macro que me diste no me funciona correctamente e cambiado la dirección del botón siguiente donde se encuentran los archivos Rdf, en este caso e creado una carpeta con los archivos RDF y el archivo de excel que me diste, la dirección es D:\TODO SOBRE MACROS\Archivos Dam
la parte que modifique en la macro fue esta y aun así no me funciona.
Sub Siguiente()
'Por.Dante Amor
'
Set h1 = Sheets("REGISTROS")
Set h2 = Sheets("conexion")
Set h3 = Sheets("archivos")
'
If h3.[A1] = "" Then
End If
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;D:\TODO SOBRE MACROS\Archivos Dam\96645_4095.rdf", Destination:=Range("$A$1"))
.Name = "96645_4095"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End SubEn el código e notado que una parte pones los números 96645_4095 de cuales este numero no siempre son los mismos en los archivos RDF.
Te e enviado a tu correo Todos los archivos RDF para los cambios que sean necesarios, espero no causar tanto problema con este tema.
Tienes que poner el archivo con la macro en la misma carpeta donde tienes los demás archivos
Bueno e realizado todo lo que indicas y aun así no trabaja, al ejecutar o cambiar la fecha en celda L5 presiono Enter esta empieza a buscar hasta que la hoja se torna oscura tanto así que se queda en ese estado y sin resultado, bueno no se cual seria el problema.
Al abrir el archivo de excel y sin modificar nada presiono el botón siguiente me manda error indicando que no se puede encontrar el archivo, presiono depurar se va a Refresh BackgroundQuery:=False de la macro.
Sub AbrirArchivo(h2, arch)
'Por.Dante Amor
With h2.QueryTables.Add(Connection:= _
"TEXT;" & arch, Destination:=h2.Range("$A$1"))
.Name = "96645_4095"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End SubBueno no se cual seria el inconveniente.
Grabaste la macro
Bueno Amigo Dante Amor
Por más que he revisado y le he dado vuelta a mi tema no he dado con el problema y no me funciona. No se si la macro se podría hacer con los códigos que tienen los archivos ya que esto seria más fácil de ubicar; es decir en ves de poner fecha en la celda L5 poner el código que tiene cada archivo rdf por ejemplo: 96645_4215, bueno si no es mucho pedir seria algo así para cerrar este tema.
Ante todo muchísimas gracias por la gran ayuda que me brindas.
¿Ya probaste con el archivo que te envié?
¿Generaste la macro que te pedí?
¿Dime qué mensaje de error te aparece?
Los archivos que cargas, cuando los cargues te debe poner la fecha en la celda A3.
Si modificas mi macro no puedo ayudarte, tienes que ejecutar la macro tal y como te la envié y poner los archivo que me enviaste en la misma carpeta.
Hola Amigo Dante
E probado con el archivo que me diste pero nada no me funciona se queda buscando hasta el punto que se torna negra la hoja espero varios minutos sin resultado alguno.
E grabado una macro con la que me trae los datos del archivo Rdf y sin problema alguno. no se como podría hacerlo para que me pueda funcionar el boton siguiente para visualizar los otros archivos.
La macro que grave y me trae los datos sin problemas es la siguiente.
Sub ArchiboRDF() ' ' ArchiboRDF Macro ' ' With ActiveSheet.QueryTables.Add(Connection:= _ "TEXT;D:\TODO SOBRE MACROS\TEMPERATURAS\96645_4123.rdf", Destination:=Range( _ "$A$1")) .Name = "96645_4123" .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .RefreshStyle = xlInsertDeleteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .TextFilePromptOnRefresh = False .TextFilePlatform = 850 .TextFileStartRow = 1 .TextFileParseType = xlDelimited .TextFileTextQualifier = xlTextQualifierDoubleQuote .TextFileConsecutiveDelimiter = False .TextFileTabDelimiter = True .TextFileSemicolonDelimiter = False .TextFileCommaDelimiter = False .TextFileSpaceDelimiter = False .TextFileColumnDataTypes = Array(1, 1) .TextFileTrailingMinusNumbers = True .Refresh BackgroundQuery:=False End With End Sub
Bueno no se cual seria el inconveniente para hacer que el botón siguiente me trabaje.
Te anexo la macro actualizada con la macro que me enviaste.
Cambia las macros por estas nuevas.
Guarda el archivo con la macro en la misma carpeta donde tienes los archivos rdf, procura probar con unos 4 o 5 archivos.
Modifica la celda L5, hasta que pongas una nueva fecha en la celda L5 se activarán los archivos.
Después ya puedes presionar el botón siguiente.
Private Sub CommandButton1_Click()
'Por.Dante Amor
'Siguiente
Application.ScreenUpdating = False
Set h1 = Sheets("REGISTROS")
Set h2 = Sheets("conexion")
Set h3 = Sheets("archivos")
For i = 1 To h3.Range("A" & Rows.Count).End(xlUp).Row
If h3.Cells(i, "B") = "x" Then
h3.Cells(i, "B") = ""
h2.Cells.Delete
If h3.Cells(i + 1, "A") <> "" Then
h3.Cells(i + 1, "B") = "x"
Call AbrirArchivo(h2, h3.Cells(i + 1, "A"))
Else
h3.Cells(1, "B") = "x"
Call AbrirArchivo(h2, h3.Cells(1, "A"))
End If
h2.Columns("A:J").Copy
h1.[A1].PasteSpecial xlValue
Exit For
End If
Next
End Sub
'
Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("L5")) Is Nothing Then
Application.ScreenUpdating = False
Set h1 = Sheets("REGISTROS")
Set h2 = Sheets("conexion")
Set h3 = Sheets("archivos")
h3.Cells.Clear
fila = 1
ruta = ThisWorkbook.Path & "\"
arch = Dir(ruta & "*.rdf")
Do While arch <> ""
h2.Cells.Delete
Call AbrirArchivo(h2, ruta & arch)
fecha = CDate(Format(h2.[A3], "dd/mm/yyyy"))
If h1.[L5] = fecha Then
h3.Cells(fila, "A") = ruta & arch
fila = fila + 1
End If
arch = Dir()
Loop
If fila = 1 Then
MsgBox "No hay archivos con la fecha indicada"
Else
h2.Cells.Delete
Call AbrirArchivo(h2, h3.[A1])
h2.Columns("A:J").Copy
h1.[A1].PasteSpecial xlValue
h3.[B1] = "x"
End If
End If
End Sub
'
Sub AbrirArchivo(h2, arch)
'Por.Dante Amor
With h2.QueryTables.Add(Connection:= _
"TEXT;" & arch, Destination:=h2.Range("$A$1"))
.Name = "96645_4123"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
' With h2.QueryTables.Add(Connection:= _
' "TEXT;" & arch, Destination:=h2.Range("$A$1"))
' .Name = "96645_4095"
' .FieldNames = True
' .RowNumbers = False
' .FillAdjacentFormulas = False
' .PreserveFormatting = True
' .RefreshOnFileOpen = False
' .RefreshStyle = xlInsertDeleteCells
' .SavePassword = False
' .SaveData = True
' .AdjustColumnWidth = True
' .RefreshPeriod = 0
' .TextFilePromptOnRefresh = False
' .TextFilePlatform = 850
' .TextFileStartRow = 1
' .TextFileParseType = xlDelimited
' .TextFileTextQualifier = xlTextQualifierDoubleQuote
' .TextFileConsecutiveDelimiter = False
' .TextFileTabDelimiter = True
' .TextFileSemicolonDelimiter = False
' .TextFileCommaDelimiter = False
' .TextFileSpaceDelimiter = False
' .TextFileColumnDataTypes = Array(1, 1)
' .TextFileTrailingMinusNumbers = True
' .Refresh BackgroundQuery:=False
' End With
End Sub
'
'
Private Sub CommandButton3_Click()
'Por.Dante Amor
'Anterior
Application.ScreenUpdating = False
Set h1 = Sheets("REGISTROS")
Set h2 = Sheets("conexion")
Set h3 = Sheets("archivos")
For i = 1 To h3.Range("A" & Rows.Count).End(xlUp).Row
If h3.Cells(i, "B") = "x" Then
h3.Cells(i, "B") = ""
h2.Cells.Delete
If i = 1 Then
u = h3.Range("A" & Rows.Count).End(xlUp).Row
h3.Cells(u, "B") = "x"
Call AbrirArchivo(h2, h3.Cells(u, "A"))
Else
h3.Cells(i - 1, "B") = "x"
Call AbrirArchivo(h2, h3.Cells(i - 1, "A"))
End If
h2.Columns("A:J").Copy
h1.[A1].PasteSpecial xlValue
Exit For
End If
Next
End SubPrueba y me comentas.
Gracias! Dante Amor por la maravillosa ayuda, ahora si funciona perfectamente pero e notado una dificultad que tiene la macro. Cuando hay mayor numero de archivos rdf esta tarda en ubicar el archivo hasta el punto que la hoja se torna negra pero cuando hay unos 30 archivos rdf esta se ejecuta normalmente y sin problemas; mi duda es como seria si yo coloco esta macro en la carpeta donde se guardan los archivos rdf ya que en esta carpeta se encuentra por lo menos unos 20000 archivos rdf, la macro tardaría un montón en ubicar un archivo.
El primer paso de la macro, es abrir todos los archivos, uno por uno, para revisar cuáles son los que pertenecen a la fecha que pusiste en la celda.
Una vez que ya tiene la lista de nombres de archivo, lo demás es ir al siguiente o al anterior.
Si pones en la carpeta solamente los archivos que pertenecen al día. Eso ahorraría el primer paso. La macro, podría en la lista todos los archivos que están en la carpeta.
La otra opción es que tu armes la lista de archivos que quieres visualizar, eso también ahorraría el primer paso. Entonces solamente serían necesarias las macros Siguiente y Anterior.
Otra opción es cambiar la forma de abrir los archivos, actualmente estamos utilizando el método Querytables. Add (es la forma en la que me dijiste que los abrías). Podemos abrirlos como texto o con Open; y probar cuál método es el más rápido. Para ello tendría que crear una nueva macro y probarla. Si quieres probar con algún otro método, crea una nueva pregunta.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
¡Gracias! Te entiendo perfectamente.
Sería bueno tener la otra opción que indicas, estaré asiendo una nueva pregunta y gracias por la gran ayuda y por el tiempo que te a tomado en hacer esta macro, muchísimas gracias doy por resuelto este tema.
