Traer Datos de un Archivo RDF a Hoja Excel con macros

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 Sub

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

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

Prueba 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